From: simonpj Date: Fri, 1 May 1998 16:26:24 +0000 (+0000) Subject: [project @ 1998-05-01 16:26:11 by simonpj] X-Git-Tag: Approx_2487_patches~730 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b117679aefcfabd2f8b34a9f495ede8508d7f88d;p=ghc-hetmet.git [project @ 1998-05-01 16:26:11 by simonpj] Fix two small renamer bugs, and Christophs duplicated-constraint-in-interface files bug --- diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 25d28e0..a45926d 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 d55e522..4d774dd 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 e7c1d38..e3efa78 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 0c52ae8..51ce967 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 6195aea..edb4cc5 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 68bd7a7..64ceff4 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