= addErrRn (badImportItemErr mod item) `thenRn_`
returnRn NotAvailable
- | otherwise = returnRn filtered_avail
+ | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn filtered_avail
+
+ | otherwise = returnRn filtered_avail
where
maybe_in_import_avails = lookupFM import_fm (ieOcc item)
Just avail = maybe_in_import_avails
filtered_avail = filterAvail item avail
+ dodgy_import = case (item, avail) of
+ (IEThingAll _, AvailTC _ [n]) -> True
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+
+ other -> False
+
\end{code}
= sep [ptext SLIT("Module"), quotes (pprModule mod),
ptext SLIT("does not export"), quotes (ppr ie)]
+dodgyImportWarn mod (IEThingAll tc)
+ = sep [ptext SLIT("Module") <+> quotes (pprModule mod) <+> ptext SLIT("exports") <+> quotes (ppr tc),
+ ptext SLIT("with no constructors/class operations;"),
+ ptext SLIT("yet it is imported with a (..)")]
+
modExportErr mod
= hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModule mod)]
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType, TcTyVar, TcTyVarSet,
- zonkSigTyVar, tcInstSigTyVars, tcInstType, tcInstTheta
+ zonkSigTyVar, tcInstSigType, tcInstTheta
)
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
)
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(..)
splitSigmaTy, isTyVarTy, mkSigmaTy,
splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe, splitRhoTy,
- tyVarsOfTypes
+ tyVarsOfTypes, mkTyVarTys,
)
import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
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) ->
%* *
%************************************************************************
-@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)
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat ) where
+module TcPat ( tcPat, badFieldsCon ) where
#include "HsVersions.h"
tcLookupLocalValueOK, tcInstId
)
import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
+import FieldLabel ( fieldLabelName )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Maybes ( maybeToBool )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
-import Id ( GenId, idType, Id )
+import Id ( GenId, idType, Id, dataConFieldLabels )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Type ( splitFunTys, splitRhoTy,
splitFunTy_maybe, splitAlgTyConApp_maybe,
-- behave differently when called, not when used for
-- matching.
(_, record_ty) = splitFunTys con_tau
+
+ field_names = map fieldLabelName (dataConFieldLabels con_id)
+ bad_fields = [f | (f,_,_) <- rpats, not (f `elem` field_names)]
in
+ -- Check that all the fields are from this constructor
+ checkTc (null bad_fields) (badFieldsCon name bad_fields) `thenTc_`
+
-- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
returnTc (con_id, con_result)
\end{code}
-
% =================================================
Errors and contexts
recordRhs field_label pat
= hang (ptext SLIT("In the record field pattern"))
4 (sep [ppr field_label, char '=', ppr pat])
+
+badFieldsCon :: Name -> [Name] -> SDoc
+badFieldsCon con fields
+ = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
+ ptext SLIT("does not have field(s):"), pprQuotedList fields]
\end{code}
+
projects / ghc-hetmet.git / commitdiff