From b117679aefcfabd2f8b34a9f495ede8508d7f88d Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 1 May 1998 16:26:24 +0000
Subject: [PATCH] [project @ 1998-05-01 16:26:11 by simonpj] Fix two small
renamer bugs, and Christophs duplicated-constraint-in-interface files bug
---
ghc/compiler/rename/RnNames.lhs | 18 +++++++-
ghc/compiler/rename/RnSource.lhs | 2 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 66 ++++++++++++++++-----------
ghc/compiler/typecheck/TcInstUtil.lhs | 15 ++++--
ghc/compiler/typecheck/TcPat.lhs | 18 ++++++--
ghc/compiler/utils/UniqFM.lhs | 7 ++-
6 files changed, 89 insertions(+), 37 deletions(-)
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 25d28e0173f0..a45926dfc443 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -281,12 +281,23 @@ filterImports mod (Just (want_hiding, import_items)) avails
= 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}
@@ -604,6 +615,11 @@ badImportItemErr mod ie
= 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)]
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index d55e5225b84e..4d774dd9f440 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -717,7 +717,7 @@ classTyVarNotInOpTyErr clas_tyvar sig
4 (ppr sig)
dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicated class assertion"),
+ = sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (pprClassAssertion assertion),
ptext SLIT("in the context:")],
nest 4 (pprContext ctxt)]
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index e7c1d38ec592..e3efa78ecccb 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -39,7 +39,7 @@ 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,
@@ -47,8 +47,8 @@ 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(..)
@@ -61,7 +61,7 @@ import Type ( Type, ThetaType, isUnpointedType,
splitSigmaTy, isTyVarTy, mkSigmaTy,
splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe, splitRhoTy,
- tyVarsOfTypes
+ tyVarsOfTypes, mkTyVarTys,
)
import TyVar ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
@@ -187,8 +187,9 @@ tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src
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
@@ -315,22 +316,26 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
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) ->
@@ -466,7 +471,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
%* *
%************************************************************************
-@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@
@@ -476,7 +481,11 @@ compiled elsewhere). In these cases, we let them go through anyway.
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)
@@ -486,20 +495,20 @@ scrutiniseInstanceType clas inst_taus
--
(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)
@@ -511,13 +520,13 @@ scrutiniseInstanceType clas inst_taus
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
@@ -566,7 +575,12 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
\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)
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 0c52ae876792..51ce9677fd22 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -39,6 +39,7 @@ import TyVar ( TyVar, zipTyVarEnv )
import Unique ( Unique )
import Util ( equivClasses, panic, assertPanic )
import Outputable
+import List ( nub )
\end{code}
instance c => k (t tvs) where b
@@ -98,13 +99,19 @@ mkInstanceRelatedIds dfun_name clas inst_tyvars inst_tys inst_decl_theta
sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
- [] -> [] -- If inst_decl_theta is empty, then we don't
+ [] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
-- expose the constant methods.
- other -> inst_decl_theta ++ sc_theta'
- -- Otherwise we pass the superclass dictionaries to
- -- the dictionary function; the Mark Jones optimisation.
+ other -> nub (inst_decl_theta ++ sc_theta')
+ -- Otherwise we pass the superclass dictionaries to
+ -- the dictionary function; the Mark Jones optimisation.
+ --
+ -- NOTE the "nub". I got caught by this one:
+ -- class Monad m => MonadT t m where ...
+ -- instance Monad m => MonadT (EnvT env) m where ...
+ -- Here, the inst_decl_theta has (Monad m); but so
+ -- does the sc_theta'!
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 6195aea52e2d..edb4cc52c8dd 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -4,7 +4,7 @@
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat ) where
+module TcPat ( tcPat, badFieldsCon ) where
#include "HsVersions.h"
@@ -22,12 +22,13 @@ import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey,
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,
@@ -194,7 +195,13 @@ tcPat pat_in@(RecPatIn name rpats)
-- 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) )
@@ -365,7 +372,6 @@ matchConArgTys con arg_tys
returnTc (con_id, con_result)
\end{code}
-
% =================================================
Errors and contexts
@@ -381,4 +387,10 @@ recordLabel field_label
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}
+
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 68bd7a71f482..64ceff4e4f1c 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -82,8 +82,11 @@ addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
-addToUFM_C :: Uniquable key => (elt -> elt -> elt)
- -> UniqFM elt -> key -> elt -> UniqFM elt
+addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
+ -> UniqFM elt -- old
+ -> key -> elt -- new
+ -> UniqFM elt -- result
+
addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
--
GitLab