import Inst ( Inst, InstOrigin(..),
newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo )
+import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon )
import TcKind ( TcKind, unifyKind )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType, TcTyVar, TcTyVarSet,
- zonkSigTyVar, tcInstSigTyVars, tcInstType, tcInstTheta
+ zonkSigTyVar, tcInstSigType, tcInstTheta
)
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
foldBag, bagToList, Bag
)
-import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
+import CmdLineOpts ( opt_GlasgowExts )
import Class ( classBigSig, Class )
-import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, Id )
-import Maybes ( maybeToBool, seqMaybe, catMaybes )
+import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, idType, Id )
+import Maybes ( maybeToBool, seqMaybe, catMaybes, expectJust )
import Name ( nameOccName, mkLocalName,
isLocallyDefined, Module,
NamedThing(..)
)
-import PrelVals ( nO_METHOD_BINDING_ERROR_ID, eRROR_ID )
+import PrelVals ( eRROR_ID )
import PprType ( pprParendType, pprConstraint )
import SrcLoc ( SrcLoc, noSrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
splitSigmaTy, isTyVarTy, mkSigmaTy,
splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe, splitRhoTy,
- tyVarsOfTypes
+ tyVarsOfTypes, mkTyVarTys,
)
import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
\end{enumerate}
\begin{code}
-tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids
+tcInstDecls1 :: GlobalValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
-> Module -- module name for deriving
-> RnNameSupply -- for renaming derivings
returnTc (full_inst_info, deriv_binds, ddump_deriv)
-tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: GlobalValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
= -- Prime error recovery, set source location
Just pair -> pair
in
- -- Check for respectable instance type
- scrutiniseInstanceType clas inst_tys `thenTc_`
+ -- Check for respectable instance type, and context
+ scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
+ mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
-- Make the dfun id and constant-method ids
let
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc locn $
- -- Get the class signature
- let
- origin = InstanceDeclOrigin
+ -- Instantiate the instance decl with tc-style type variables
+ tcInstSigType (idType dfun_id) `thenNF_Tc` \ dfun_ty' ->
+ let
+ (inst_tyvars',
+ dfun_theta', dict_ty') = splitSigmaTy dfun_ty'
+
+ (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+
(class_tyvars,
sc_theta, sc_sel_ids,
- op_sel_ids, defm_ids) = classBigSig clas
+ op_sel_ids, defm_ids) = classBigSig clas
+
+ origin = InstanceDeclOrigin
in
-
- -- Instantiate the instance decl with tc-style type variables
- tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
- mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' ->
- tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
- tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
+ -- Instantiate the theta found in the original instance decl
+ tcInstTheta (zipTyVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
- -- Instantiate the super-class context with inst_tys
- tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
+ -- Instantiate the super-class context with the instance types
+ tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
tcExtendGlobalValEnv (catMaybes defm_ids) (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds uprags)
+ mapAndUnzip3Tc (tcMethodBind clas origin inst_tys' inst_tyvars' monobinds uprags True)
(op_sel_ids `zip` defm_ids)
) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
methods_lie = plusLIEs insts_needed_s
in
+ -- Ditto method bindings
+ tcAddErrCtxt methodCtxt (
+ tcSimplifyAndCheck
+ (ptext SLIT("instance declaration context"))
+ inst_tyvars_set -- Local tyvars
+ avail_insts
+ methods_lie
+ ) `thenTc` \ (const_lie1, lie_binds1) ->
+
-- Check that we *could* construct the superclass dictionaries,
-- even though we are *actually* going to pass the superclass dicts in;
- -- the check ensures that the caller will never have a problem building
- -- them.
+ -- the check ensures that the caller will never have
+ --a problem building them.
tcAddErrCtxt superClassCtxt (
tcSimplifyAndCheck
(ptext SLIT("instance declaration context"))
-- Ignore the result; we're only doing
-- this to make sure it can be done.
- -- Ditto method bindings
- tcAddErrCtxt methodCtxt (
- tcSimplifyAndCheck
- (ptext SLIT("instance declaration context"))
- inst_tyvars_set -- Local tyvars
- avail_insts
- methods_lie
- ) `thenTc_`
-
- -- Now do the simplification again, this time to get the
- -- bindings; this time we use an enhanced "avails"
- -- Ignore errors because they come from the *previous* tcSimplifys
+ -- Now do the simplification again, this time to get the
+ -- bindings; this time we use an enhanced "avails"
+ -- Ignore errors because they come from the *previous* tcSimplify
discardErrsTc (
tcSimplifyAndCheck
(ptext SLIT("instance declaration context"))
inst_tyvars_set
dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
-- get bound by just selecting from this_dict!!
- (sc_dicts `plusLIE` methods_lie `plusLIE` prag_lie)
- ) `thenTc` \ (const_lie, lie_binds) ->
+ sc_dicts
+ ) `thenTc` \ (const_lie2, lie_binds2) ->
-- Create the result bindings
-- 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.
- HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
- (HsLitOut (HsString msg) stringTy)
+ HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
+ (HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
- (map HsVar (sc_dict_ids ++ meth_ids))
+ = HsCon dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
- -- rely on the simplifier to unfold this saturated application
+ -- just generate the saturated constructor directly
where
msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
zonked_inst_tyvars
dfun_arg_dicts_ids
[(inst_tyvars', RealId final_dfun_id, this_dict_id)]
- (lie_binds `AndMonoBinds`
+ (lie_binds1 `AndMonoBinds`
+ lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
- prag_binds `AndMonoBinds`
dict_bind)
in
- returnTc (const_lie,
+ returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
main_bind `AndMonoBinds` prag_binds)
\end{code}
%************************************************************************
%* *
-\subsection{Processing each method}
-%* *
-%************************************************************************
-
-\begin{code}
-tcInstMethodBind
- :: Class
- -> [TcType s] -- Instance types
- -> [TcTyVar s] -- and their free (sig) tyvars
- -> RenamedMonoBinds -- Method binding
- -> [RenamedSig] -- Pragmas
- -> (Id, Maybe Id) -- Selector id and default-method id
- -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-
-tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id)
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ uniq ->
- let
- sel_name = idName sel_id
- meth_occ = getOccName sel_name
- default_meth_name = mkLocalName uniq meth_occ loc
- maybe_meth_bind = find sel_name meth_binds
- the_meth_bind = case maybe_meth_bind of
- Just stuff -> stuff
- Nothing -> mk_default_bind default_meth_name loc
- meth_prags = sigsForMe (== sel_name) prags
- in
-
- -- Warn if no method binding, only if -fwarn-missing-methods
-
- warnTc (opt_WarnMissingMethods &&
- not (maybeToBool maybe_meth_bind) &&
- not (maybeToBool maybe_dm_id))
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
-
- -- Typecheck the method binding
- tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind meth_prags
- where
- origin = InstanceDeclOrigin -- Poor
-
- find sel EmptyMonoBinds = Nothing
- find sel (AndMonoBinds b1 b2) = find sel b1 `seqMaybe` find sel b2
-
- find sel b@(FunMonoBind op_name _ _ _) | op_name == sel = Just b
- | otherwise = Nothing
- find sel b@(PatMonoBind (VarPatIn op_name) _ _) | op_name == sel = Just b
- | otherwise = Nothing
- find sel other = panic "Urk! Bad instance method binding"
-
-
- mk_default_bind local_meth_name loc
- = PatMonoBind (VarPatIn local_meth_name)
- (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
- loc
-
- default_expr loc
- = case maybe_dm_id of
- Just dm_id -> HsVar (getName dm_id) -- There's a default method
- Nothing -> error_expr loc -- No default method
-
- error_expr loc
- = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
- (HsLit (HsString (_PK_ (error_msg loc))))
-
- error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection{Checking for a decent instance type}
%* *
%************************************************************************
-@scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
+@scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
it must normally look like: @instance Foo (Tycon a b c ...) ...@
The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
-scrutiniseInstanceType clas inst_taus
+scrutiniseInstanceConstraint (clas, tys)
+ | all isTyVarTy tys = returnNF_Tc ()
+ | otherwise = addErrTc (instConstraintErr clas tys)
+
+scrutiniseInstanceHead clas inst_taus
| -- CCALL CHECK (a).... urgh!
-- To verify that a user declaration of a CCallable/CReturnable
-- instance is OK, we must be able to see the constructor(s)
--
(uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey)
&& is_alg_tycon_app && not constructors_visible
- = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
+ = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
| -- CCALL CHECK (b)
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
(uniqueOf clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
(uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
- = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
+ = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- DERIVING CHECK
-- It is obviously illegal to have an explicit instance
-- for something that we are also planning to `derive'
| maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
- = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
+ = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-- Kind check will have ensured inst_taus is of length 1
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
-- This last condition checks that all the type variables are distinct
)
- = failWithTc (instTypeErr clas inst_taus
+ = addErrTc (instTypeErr clas inst_taus
(text "the instance type must be of form (T a b c)" $$
text "where T is not a synonym, and a,b,c are distinct type variables")
)
| otherwise
- = returnTc ()
+ = returnNF_Tc ()
where
(first_inst_tau : _) = inst_taus
\end{code}
\begin{code}
-
+instConstraintErr clas tys
+ = hang (ptext SLIT("Illegal constaint") <+>
+ quotes (pprConstraint clas tys) <+>
+ ptext SLIT("in instance context"))
+ 4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
+
instTypeErr clas tys msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
nest 4 (parens msg)
4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
ppr inst_ty])
-omittedMethodWarn sel_id clas
- = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
- ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
-
{-
Declaring CCallable & CReturnable instances in a module different
from where the type was defined. Caused by importing data type