#include "HsVersions.h"
import HsSyn
-import TcBinds ( tcSpecSigs, badBootDeclErr )
+import TcBinds ( mkPragFun, tcPrags, badBootDeclErr )
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
-import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr,
- checkAmbiguity, SourceTyCtxt(..) )
-import TcType ( mkClassPred, tyVarsOfType,
- tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
- SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
+import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead )
+import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
+ SkolemInfo(InstSkol), tcSplitDFunTy )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE,
getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv,
- InstInfo(..), InstBindings(..),
+import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import DataCon ( classDataCon )
import Class ( classBigSig )
import Var ( Id, idName, idType )
-import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
-import FunDeps ( checkInstFDs )
+import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc )
-import NameSet ( unitNameSet, emptyNameSet )
-import UnicodeUtil ( stringToUtf8 )
import Maybe ( catMaybes )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
import Bag
+import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
import FastString
\end{code}
-> TcM (TcGblEnv, -- The full inst env
[InstInfo], -- Source-code instance decls to process;
-- contains all dfuns for this module
- [HsBindGroup Name]) -- Supporting bindings for derived instances
+ HsValBinds Name) -- Supporting bindings for derived instances
tcInstDecls1 tycl_decls inst_decls
= checkNoErrs $
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
- -- but only do this for non-imported instance decls.
- -- Imported ones should have been checked already, and may indeed
- -- contain something illegal in normal Haskell, notably
- -- instance CCallable [Char]
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
= -- Prime error recovery, set source location
recoverM (returnM Nothing) $
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.
- kcHsSigType poly_ty `thenM` \ kinded_ty ->
- tcHsKindedType kinded_ty `thenM` \ poly_ty' ->
- let
- (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
- in
- checkValidTheta InstThetaCtxt theta `thenM_`
- checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_`
- checkValidInstHead tau `thenM` \ (clas,inst_tys) ->
- checkTc (checkInstFDs theta clas inst_tys)
- (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_`
- newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name ->
- getOverlapFlag `thenM` \ overlap_flag ->
- let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
- ispec = mkLocalInstance dfun overlap_flag
- in
-
- tcIsHsBoot `thenM` \ is_boot ->
- checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
- badBootDeclErr `thenM_`
-
- returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags }))
- where
- msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
+ ; kinded_ty <- kcHsSigType poly_ty
+ ; poly_ty' <- tcHsKindedType kinded_ty
+ ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+
+ ; (clas, inst_tys) <- checkValidInstHead tau
+ ; checkValidInstance tyvars theta clas inst_tys
+
+ ; 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 (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) }
\end{code}
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
- -> TcM (TcLclEnv, LHsBinds Id)
+ -> TcM (LHsBinds Id, TcLclEnv)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
; inst_binds_s <- mappM tcInstDecl2 inst_decls
-- Done
- ; tcl_env <- getLclEnv
- ; returnM (tcl_env, unionManyBags dm_binds_s `unionBags`
- unionManyBags inst_binds_s) }
+ ; let binds = unionManyBags dm_binds_s `unionBags`
+ unionManyBags inst_binds_s
+ ; tcl_env <- getLclEnv -- Default method Ids in here
+ ; returnM (binds, tcl_env) }
\end{code}
======= New documentation starts here (Sept 92) ==============
-- of the inst_tyavars' with something in the envt
checkSigTyVars inst_tyvars' `thenM_`
- -- Deal with 'SPECIALISE instance' pragmas by making them
- -- look like SPECIALISE pragmas for the dfun
+ -- Deal with 'SPECIALISE instance' pragmas
let
- uprags = case binds of
- VanillaInst _ uprags -> uprags
- other -> []
- spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty)
- | L loc (SpecInstSig ty) <- uprags ]
+ specs = case binds of
+ VanillaInst _ prags -> filter isSpecInstLSig prags
+ other -> []
in
- tcExtendGlobalValEnv [dfun_id] (
- tcExtendTyVarEnv inst_tyvars' $
- tcSpecSigs spec_prags
- ) `thenM` \ prag_binds ->
-
+ tcPrags dfun_id specs `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
- inlines | null dfun_arg_dicts = emptyNameSet
- | otherwise = unitNameSet (idName dfun_id)
+ 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
-- See Note [Inline dfuns] below
dict_rhs
- | null scs_and_meths
- = -- Blatant special case for CCallable, CReturnable
- -- If the dictionary is empty then we should never
- -- select anything from it, so we make its RHS just
- -- emit an error message. This in turn means that we don't
- -- mention the constructor, which doesn't exist for CCallable, CReturnable
- -- Hardly beautiful, but only three extra lines.
- nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID)
- [idType this_dict_id])
- (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
-
- | otherwise -- The common case
= 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
-- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
- where
- msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
-
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)]
- inlines all_binds
+ [(inst_tyvars', dfun_id, this_dict_id,
+ inline_prag ++ prags)]
+ all_binds
in
showLIE (text "instance") `thenM_`
- returnM (unitBag main_bind `unionBags`
- prag_binds )
+ returnM (unitBag main_bind)
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
-- 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
- tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags
+ tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
in