From d3e697b8d842bd43329d470f2bc424a6dcb88d89 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 10 Feb 1998 14:17:06 +0000 Subject: [PATCH 1/1] [project @ 1998-02-10 14:15:51 by simonpj] Several small fixes to multi-param type classes --- ghc/compiler/absCSyn/CLabel.lhs | 4 +- ghc/compiler/basicTypes/Id.lhs | 54 ++++----- ghc/compiler/codeGen/CgClosure.lhs | 70 ++++++------ ghc/compiler/codeGen/ClosureInfo.lhs | 8 +- ghc/compiler/coreSyn/CoreUtils.lhs | 26 +++-- ghc/compiler/deSugar/DsBinds.lhs | 1 + ghc/compiler/deSugar/MatchLit.lhs | 4 +- ghc/compiler/hsSyn/HsExpr.lhs | 32 +++--- ghc/compiler/prelude/StdIdInfo.lhs | 72 +++++------- ghc/compiler/reader/PrefixToHs.lhs | 2 + ghc/compiler/reader/RdrHsSyn.lhs | 13 ++- ghc/compiler/rename/Rename.lhs | 66 +++++++---- ghc/compiler/rename/RnBinds.lhs | 47 ++++---- ghc/compiler/rename/RnEnv.lhs | 22 ++-- ghc/compiler/rename/RnNames.lhs | 45 +++++--- ghc/compiler/simplCore/Simplify.lhs | 5 +- ghc/compiler/specialise/Specialise.lhs | 2 +- ghc/compiler/typecheck/Inst.lhs | 8 +- ghc/compiler/typecheck/TcBinds.lhs | 32 ++++-- ghc/compiler/typecheck/TcClassDcl.lhs | 19 +++- ghc/compiler/typecheck/TcExpr.lhs | 23 ++-- ghc/compiler/typecheck/TcInstDcls.lhs | 99 +++++++++-------- ghc/compiler/typecheck/TcMonad.lhs | 4 +- ghc/compiler/typecheck/TcMonoType.lhs | 58 +++++----- ghc/compiler/typecheck/TcPat.lhs | 3 +- ghc/compiler/typecheck/TcSimplify.lhs | 188 ++++++++++++++------------------ ghc/compiler/typecheck/TcType.lhs | 3 + ghc/compiler/typecheck/Unify.lhs | 1 + ghc/compiler/types/Type.lhs | 16 ++- 29 files changed, 483 insertions(+), 444 deletions(-) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 94b84e5..6111c6a 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -57,8 +57,8 @@ import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, isDefaultMethodId_maybe, - isSuperDictSelId_maybe, fIRST_TAG, - ConTag, GenId{-instance Outputable-}, + fIRST_TAG, + ConTag, Id ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5113340..927d333 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -64,10 +64,9 @@ module Id ( isDictFunId, isImportedId, isRecordSelector, - isMethodSelId_maybe, + isDictSelId_maybe, isNullaryDataCon, isSpecPragmaId, - isSuperDictSelId_maybe, isPrimitiveId_maybe, isSysLocalId, isTupleCon, @@ -246,18 +245,8 @@ data IdDetails ---------------- Things to do with overloading - | SuperDictSelId -- Selector for superclass dictionary - Class -- The class (input dict) - Class -- The superclass (result dict) - - | MethodSelId Class -- An overloaded class operation, with - -- a fully polymorphic type. Its code - -- just selects a method from the - -- dictionary. - - -- NB: The IdInfo for a MethodSelId has all the info about its - -- related "constant method Ids", which are just - -- specialisations of this general one. + | DictSelId -- Selector that extracts a method or superclass from a dictionary + Class -- The class | DefaultMethodId -- Default method for a particular class op Class -- same class, info as MethodSelId @@ -478,8 +467,7 @@ toplevelishId (Id _ _ _ details _ _) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk (SuperDictSelId _ _) = True - chk (MethodSelId _) = True + chk (DictSelId _) = True chk (DefaultMethodId _) = True chk (DictFunId _ _) = True chk (SpecId unspec _ _) = toplevelishId unspec @@ -496,8 +484,7 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk (SuperDictSelId _ _) = True - chk (MethodSelId _) = True + chk (DictSelId _) = True chk (DefaultMethodId _) = True chk (DictFunId _ _) = True chk (SpecId _ _ no_free_tvs) = no_free_tvs @@ -530,8 +517,7 @@ omitIfaceSigForId (Id _ name _ details _ _) (AlgConId _ _ _ _ _ _ _ _ _) -> True (TupleConId _) -> True (RecordSelId _) -> True - (SuperDictSelId _ _) -> True - (MethodSelId _) -> True + (DictSelId _) -> True other -> False -- Don't omit! -- NB DefaultMethodIds are not omitted @@ -555,8 +541,8 @@ isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) isSpecId_maybe other_id = Nothing -isMethodSelId_maybe (Id _ _ _ (MethodSelId cls) _ _) = Just cls -isMethodSelId_maybe _ = Nothing +isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls +isDictSelId_maybe _ = Nothing isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True isDefaultMethodId other = False @@ -568,9 +554,6 @@ isDefaultMethodId_maybe other = Nothing isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True isDictFunId other = False -isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc) -isSuperDictSelId_maybe other_id = Nothing - isWrapperId id = workerExists (getIdStrictness id) isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop @@ -660,20 +643,26 @@ idPrimRep i = typePrimRep (idType i) %************************************************************************ \begin{code} -mkSuperDictSelId u clas sc ty +mkSuperDictSelId :: Unique -> Class -> Int -> Type -> Id + -- The Int is an arbitrary tag to say which superclass is selected + -- So, for + -- class (C a, C b) => Foo a b where ... + -- we get superclass selectors + -- Foo_sc1, Foo_sc2 + +mkSuperDictSelId u clas index ty = addStandardIdInfo $ Id u name ty details NoPragmaInfo noIdInfo where name = mkCompoundName name_fn u (getName clas) - details = SuperDictSelId clas sc - name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ - (mod,occ) = modAndOcc sc + details = DictSelId clas + name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index)) -- For method selectors the clean thing to do is -- to give the method selector the same name as the class op itself. -mkMethodSelId op_name rec_c ty +mkMethodSelId op_name clas ty = addStandardIdInfo $ - Id (uniqueOf op_name) op_name ty (MethodSelId rec_c) NoPragmaInfo noIdInfo + Id (uniqueOf op_name) op_name ty (DictSelId clas) NoPragmaInfo noIdInfo mkDefaultMethodId dm_name rec_c ty = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo @@ -951,8 +940,7 @@ dataConFieldLabels x@(Id _ _ _ idt _ _) = SpecPragmaId _ _ -> "sp" ImportedId -> "i" RecordSelId _ -> "r" - SuperDictSelId _ _ -> "sc" - MethodSelId _ -> "m" + DictSelId _ -> "m" DefaultMethodId _ -> "d" DictFunId _ _ -> "di" SpecId _ _ _ -> "spec")) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 8fbf5c6..8e32a8a 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -17,6 +17,7 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import AbsCSyn import StgSyn +import BasicTypes ( TopLevelFlag(..) ) import AbsCUtils ( mkAbstractCs, getAmodeRep ) import CgBindery ( getCAddrMode, getArgAmodes, @@ -98,17 +99,11 @@ cgTopRhsClosure name cc binder_info args body lf_info `thenC` -- BUILD VAP INFO TABLES IF NECESSARY - -- Don't build Vap info tables etc for - -- a function whose result is an unboxed type, - -- because we can never have thunks with such a type. - (if closureReturnsUnpointedType closure_info then - nopC - else - let + let bind_the_fun = addBindC name cg_id_info -- It's global! - in - cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info - ) `thenC` + in + cgVapInfoTables TopLevel bind_the_fun binder_info name args lf_info + `thenC` -- BUILD THE OBJECT (IF NECESSARY) (if staticClosureRequired name binder_info lf_info @@ -250,14 +245,8 @@ cgRhsClosure binder cc binder_info fvs args body lf_info ) `thenC` -- BUILD VAP INFO TABLES IF NECESSARY - -- Don't build Vap info tables etc for - -- a function whose result is an unboxed type, - -- because we can never have thunks with such a type. - (if closureReturnsUnpointedType closure_info then - nopC - else - cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info - ) `thenC` + cgVapInfoTables NotTopLevel nopC binder_info binder args lf_info + `thenC` -- BUILD THE OBJECT let @@ -295,10 +284,34 @@ cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info ) where - fun_in_payload = not top_level + fun_in_payload = case top_level of + TopLevel -> False + NotTopLevel -> True + cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info - = let + | closureReturnsUnpointedType closure_info + -- Don't build Vap info tables etc for + -- a function whose result is an unboxed type, + -- because we can never have thunks with such a type. + = nopC + + | otherwise + = forkClosureBody ( + + -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells + -- how to bind it. If it is in payload it'll be bound by payload_bind_details. + perhaps_bind_the_fun `thenC` + mapCs bind_fv payload_bind_details `thenC` + + -- Generate the info table and code + closureCodeBody NoStgBinderInfo + closure_info + useCurrentCostCentre + [] -- No args; it's a thunk + vap_entry_rhs + ) + where -- The vap_entry_rhs is a manufactured STG expression which -- looks like the RHS of any binding which is going to use the vap-entry -- point of the function. Each of these bindings will look like: @@ -341,23 +354,6 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info -- Id is just used for label construction, which is OK. bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info - in - - -- BUILD ITS INFO TABLE AND CODE - forkClosureBody ( - - -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells - -- how to bind it. If it is in payload it'll be bound by payload_bind_details. - perhaps_bind_the_fun `thenC` - mapCs bind_fv payload_bind_details `thenC` - - -- Generate the info table and code - closureCodeBody NoStgBinderInfo - closure_info - useCurrentCostCentre - [] -- No args; it's a thunk - vap_entry_rhs - ) \end{code} %************************************************************************ %* * diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index d14a8a7..91200a0 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -96,7 +96,8 @@ import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it import TyCon ( TyCon, isNewTyCon ) -import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys, splitAlgTyConApp_maybe, +import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys, + splitAlgTyConApp_maybe, applyTys, Type ) import Util ( isIn, mapAccumL ) @@ -1130,11 +1131,10 @@ fun_result_ty arity ty Nothing -> pprPanic "fun_result_ty:" (hsep [int arity, ppr ty]) - Just (tycon, _, [con]) | isNewTyCon tycon + Just (tycon, tycon_arg_tys, [con]) | isNewTyCon tycon -> fun_result_ty (arity - n_arg_tys) rep_ty where - ([rep_ty], _) = splitFunTys rho_ty - (_, rho_ty) = splitForAllTys (idType con) + ([rep_ty], _) = splitFunTys (applyTys (idType con) tycon_arg_tys) where (_, rho_ty) = splitForAllTys ty (arg_tys, res_ty) = splitFunTys rho_ty diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 1ecaadf..d9b9207 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -39,7 +39,7 @@ import TyVar ( cloneTyVar, TyVar, GenTyVar ) import Type ( mkFunTy, mkForAllTy, mkTyVarTy, - splitFunTy_maybe, applyTy, isUnpointedType, + splitFunTy_maybe, applyTys, isUnpointedType, splitSigmaTy, splitFunTys, instantiateTy, Type ) @@ -94,11 +94,11 @@ coreExprType (Lam (TyBinder tyvar) expr) = mkForAllTy tyvar (coreExprType expr) coreExprType (App expr (TyArg ty)) - = --- pprTrace "appTy1" (hsep [ppr fun_ty, space, ppr ty]) $ - applyTy fun_ty ty + = -- Gather type args; more efficient to instantiate the type all at once + go expr [ty] where - fun_ty = coreExprType expr + go (App expr (TyArg ty)) tys = go expr (ty:tys) + go expr tys = applyTys (coreExprType expr) tys coreExprType (App expr val_arg) = ASSERT(isValArg val_arg) @@ -127,11 +127,19 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \end{code} \begin{code} -applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args +applyTypeToArgs op_ty (TyArg ty : args) + = -- Accumulate type arguments so we can instantiate all at once + applyTypeToArgs (applyTys op_ty tys) rest_args + where + (tys, rest_args) = go [ty] args + go tys (TyArg ty : args) = go (ty:tys) args + go tys rest_args = (reverse tys, rest_args) + +applyTypeToArgs op_ty (val_or_lit_arg:args) + = case (splitFunTy_maybe op_ty) of + Just (_, res_ty) -> applyTypeToArgs res_ty args -applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty -applyTypeToArg op_ty val_or_lit_arg = case (splitFunTy_maybe op_ty) of - Just (_, res_ty) -> res_ty +applyTypeToArgs op_ty [] = op_ty \end{code} coreExprCc gets the cost centre enclosing an expression, if any. diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 8a05262..21cd4f3 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -37,6 +37,7 @@ import Type ( mkTyVarTy, isDictTy, instantiateTy ) import TyVar ( zipTyVarEnv ) import TysPrim ( voidTy ) +import Outputable ( assertPanic ) \end{code} %************************************************************************ diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index c9b6bb1..4d16d00 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -15,14 +15,14 @@ import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, Match, HsBinds, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedPat ) import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) ) -import Id ( GenId {- instance Eq -}, Id ) +import Id ( Id ) import DsMonad import DsUtils import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) -import Type ( Type ) +import Type ( Type, isUnpointedType ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 85ea35a..b4483da 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -199,7 +199,7 @@ ppr_expr (HsLam match) ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - (pprExpr fun) <+> (sep (map pprExpr args)) + (ppr_expr fun) <+> (sep (map ppr_expr args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -248,19 +248,19 @@ ppr_expr (SectionR op expr) = parens (sep [ppr v, pp_expr]) ppr_expr (HsCase expr matches _) - = sep [ sep [ptext SLIT("case"), nest 4 (ppr_expr expr), ptext SLIT("of")], + = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")], nest 2 (pprMatches (True, empty) matches) ] ppr_expr (HsIf e1 e2 e3 _) - = sep [hsep [ptext SLIT("if"), nest 2 (ppr_expr e1), ptext SLIT("then")], - nest 4 (ppr_expr e2), + = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")], + nest 4 (pprExpr e2), ptext SLIT("else"), - nest 4 (ppr_expr e3)] + nest 4 (pprExpr e3)] -- special case: let ... in let ... ppr_expr (HsLet binds expr@(HsLet _ _)) = sep [hang (ptext SLIT("let")) 2 (hsep [ppr binds, ptext SLIT("in")]), - ppr_expr expr] + pprExpr expr] ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (ppr binds), @@ -270,13 +270,13 @@ ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList exprs) - = brackets (fsep (punctuate comma (map pprExpr exprs))) + = brackets (fsep (punctuate comma (map ppr_expr exprs))) ppr_expr (ExplicitListOut ty exprs) - = hcat [ brackets (fsep (punctuate comma (map pprExpr exprs))), + = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))), ifNotPprForUser ((<>) space (parens (pprGenType ty))) ] ppr_expr (ExplicitTuple exprs) - = parens (sep (punctuate comma (map pprExpr exprs))) + = parens (sep (punctuate comma (map ppr_expr exprs))) ppr_expr (HsCon con_id tys args) = ppr con_id <+> sep (map pprParendGenType tys ++ @@ -291,7 +291,7 @@ ppr_expr (RecordUpdOut aexp _ _ rbinds) = pp_rbinds (pprParendExpr aexp) rbinds ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (pprExpr expr) <+> ptext SLIT("::")) + = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::")) 4 (ppr sig) ppr_expr (ArithSeqIn info) @@ -310,24 +310,24 @@ ppr_expr (HsSCC label expr) ppr_expr (TyLam tyvars expr) = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) - 4 (pprExpr expr) + 4 (ppr_expr expr) ppr_expr (TyApp expr [ty]) - = hang (pprExpr expr) 4 (pprParendGenType ty) + = hang (ppr_expr expr) 4 (pprParendGenType ty) ppr_expr (TyApp expr tys) - = hang (pprExpr expr) + = hang (ppr_expr expr) 4 (brackets (interpp'SP tys)) ppr_expr (DictLam dictvars expr) = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")]) - 4 (pprExpr expr) + 4 (ppr_expr expr) ppr_expr (DictApp expr [dname]) - = hang (pprExpr expr) 4 (ppr dname) + = hang (ppr_expr expr) 4 (ppr dname) ppr_expr (DictApp expr dnames) - = hang (pprExpr expr) + = hang (ppr_expr expr) 4 (brackets (interpp'SP dnames)) \end{code} diff --git a/ghc/compiler/prelude/StdIdInfo.lhs b/ghc/compiler/prelude/StdIdInfo.lhs index f9fe248..75d803b 100644 --- a/ghc/compiler/prelude/StdIdInfo.lhs +++ b/ghc/compiler/prelude/StdIdInfo.lhs @@ -24,18 +24,18 @@ import CoreSyn import Literal import CoreUnfold ( mkUnfolding, PragmaInfo(..) ) import TysWiredIn ( tupleCon ) -import Id ( GenId, mkTemplateLocals, idType, +import Id ( mkTemplateLocals, idType, dataConStrictMarks, dataConFieldLabels, dataConArgTys, recordSelectorFieldLabel, dataConSig, StrictnessMark(..), - isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe, + isAlgCon, isDictSelId_maybe, isRecordSelector, isPrimitiveId_maybe, addIdUnfolding, addIdArity, Id ) import IdInfo ( ArityInfo, exactArity ) import Class ( classBigSig, classTyCon ) -import TyCon ( isNewTyCon, tyConDataCons ) +import TyCon ( isNewTyCon, tyConDataCons, isDataTyCon ) import FieldLabel ( FieldLabel ) import PrelVals ( pAT_ERROR_ID ) import Maybes @@ -179,20 +179,35 @@ addStandardIdInfo sel_id %* * %************************************************************************ +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + \begin{code} addStandardIdInfo sel_id - | maybeToBool maybe_sc_sel_id - = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id) + | maybeToBool maybe_dict_sel_id + = sel_id `addIdUnfolding` unfolding where - maybe_sc_sel_id = isSuperDictSelId_maybe sel_id - Just (cls, _) = maybe_sc_sel_id + maybe_dict_sel_id = isDictSelId_maybe sel_id + Just clas = maybe_dict_sel_id -addStandardIdInfo sel_id - | maybeToBool maybe_meth_sel_id - = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id) - where - maybe_meth_sel_id = isMethodSelId_maybe sel_id - Just cls = maybe_meth_sel_id + unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs + -- The always-inline thing means we don't need any other IdInfo + + (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas + + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvar_tys = mkTyVarTys tyvars + arg_tys = dataConArgTys data_con tyvar_tys + the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id + + (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys) + + rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $ + Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id) + | otherwise = mkLam tyvars [dict_id] $ + Case (Var dict_id) $ + AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault \end{code} @@ -235,34 +250,3 @@ addStandardIdInfo id = pprTrace "addStandardIdInfo missing:" (ppr id) id \end{code} - -%************************************************************************ -%* * -\subsection{Dictionary selector help function -%* * -%************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -\begin{code} -mk_selector_unfolding clas sel_id - = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs - -- The always-inline thing means we don't need any other IdInfo - where - (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas - - tycon = classTyCon clas - [data_con] = tyConDataCons tycon - tyvar_tys = mkTyVarTys tyvars - arg_tys = dataConArgTys data_con tyvar_tys - the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id - - (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys) - - rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $ - Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id) - | otherwise = mkLam tyvars [dict_id] $ - Case (Var dict_id) $ - AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault -\end{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 5e16609..acc8627 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -123,6 +123,7 @@ cvMonoBindsAndSigs sf sig_cvtr fb } mangle_bind (b_acc, s_acc) other = (b_acc, s_acc) + -- Ignore class decls, instance decls etc \end{code} \begin{code} @@ -200,4 +201,5 @@ cvOtherDecls b go acc (RdrInstDecl d) = InstD d : acc go acc (RdrDefaultDecl d) = DefD d : acc go acc other = acc + -- Ignore value bindings \end{code} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index cb8e8c9..3beba6c 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -48,7 +48,7 @@ module RdrHsSyn ( isUnqual, isQual, showRdr, rdrNameOcc, rdrNameModule, ieOcc, cmpRdr, prefixRdrName, - mkOpApp, mkClassDecl + mkOpApp, mkClassDecl, isClassDataConRdrName ) where @@ -166,6 +166,17 @@ mkClassDecl cxt cname tyvars sigs mbinds prags loc where s1 = SLIT(":") _APPEND_ s +-- This nasty little function tests for whether a RdrName was +-- constructed by the above process. It's used only for filtering +-- out duff error messages. Maybe there's a tidier way of doing this +-- but I can't work up the energy to find it. + +isClassDataConRdrName rdr_name + = case rdrNameOcc rdr_name of + TCOcc s -> case _UNPK_ s of + ':' : c : _ -> isUpper c + other -> False + other -> False \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index e221088..259b90d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -23,7 +23,7 @@ import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpeci getDeferredDataDecls, mkSearchPath, getSlurpedNames, getRnStats ) -import RnEnv ( addImplicitOccsRn ) +import RnEnv ( addImplicitOccsRn, availNames ) import Name ( Name, PrintUnqualified, Provenance, isLocallyDefined, NameSet(..), nameSetToList, minusNameSet, NamedThing(..), @@ -37,6 +37,7 @@ import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, doIfSet, dumpIfSet, ghcExit ) import Bag ( isEmptyBag ) +import FiniteMap ( fmToList, delListFromFM ) import UniqSupply ( UniqSupply ) import Util ( equivClasses ) import Maybes ( maybeToBool ) @@ -95,7 +96,7 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc returnRn Nothing else let - Just (export_env, rn_env, explicit_names, print_unqual) = maybe_stuff + Just (export_env, rn_env, explicit_info, print_unqual) = maybe_stuff in -- RENAME THE SOURCE @@ -120,7 +121,7 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc getNameSupplyRn `thenRn` \ name_supply -> -- REPORT UNUSED NAMES - reportUnusedNames explicit_names `thenRn_` + reportUnusedNames export_env explicit_info `thenRn_` -- GENERATE THE SPECIAL-INSTANCE MODULE LIST -- The "special instance" modules are those modules that contain instance @@ -262,29 +263,48 @@ rn_data_decl mode (tycon_name,ty_decl) = rn_iface_decl mod_name mode (TyD ty_dec \end{code} \begin{code} -reportUnusedNames explicit_avail_names +reportUnusedNames (ExportEnv export_avails _) explicit_info + | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) + = returnRn () + + | otherwise = getSlurpedNames `thenRn` \ slurped_names -> let - unused = explicit_avail_names `minusNameSet` slurped_names - (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused) - imports_by_module = equivClasses cmp imported_unused - name1 `cmp` name2 = nameModule name1 `compare` nameModule name2 - - pp_imp = sep [text "Warning: the following unqualified imports are unused:", - nest 4 (vcat (map pp_group imports_by_module))] - pp_group (n:ns) = sep [hcat [text "Module ", pprModule (nameModule n), char ':'], - nest 4 (sep (map (pprOccName . nameOccName) (n:ns)))] - - pp_local = sep [text "Warning: the following local top-level definitions are unused:", - nest 4 (sep (map (pprOccName . nameOccName) local_unused))] - in - (if not opt_WarnUnusedImports || null imported_unused - then returnRn () - else addWarnRn pp_imp) `thenRn_` + unused_info :: FiniteMap Name HowInScope + unused_info = foldl delListFromFM + (delListFromFM explicit_info (nameSetToList slurped_names)) + (map availNames export_avails) + unused_list = fmToList unused_info + + groups = filter wanted (equivClasses cmp unused_list) + where + (name1, his1) `cmp` (name2, his2) = his1 `cmph` his2 + + (FromLocalDefn _) `cmph` (FromImportDecl _ _) = LT + (FromLocalDefn _) `cmph` (FromLocalDefn _) = EQ + (FromImportDecl m1 _) `cmph` (FromImportDecl m2 _) = m1 `compare` m2 + h1 `cmph` h2 = GT + + wanted ((_,FromImportDecl _ _) : _) = opt_WarnUnusedImports + wanted ((_,FromLocalDefn _) : _) = opt_WarnUnusedImports + + pp_imp = sep [text "Warning: the following are unused:", + nest 4 (vcat (map pp_group groups))] + + pp_group group = sep [msg <> char ':', + nest 4 (sep (map (pprOccName . nameOccName . fst) group))] + where + his = case group of + ((_,his) : _) -> his + + msg = case his of + FromImportDecl m _ -> text "Imported from" <+> pprModule m + FromLocalDefn _ -> text "Locally defined" - (if not opt_WarnUnusedBinds || null local_unused - then returnRn () - else addWarnRn pp_local) + in + if null groups + then returnRn () + else addWarnRn pp_imp rnStats :: [RenamedHsDecl] -> RnMG () rnStats all_decls diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 92e221e..8780058 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -263,10 +263,10 @@ rn_mono_binds top_lev binders mbinds sigs -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned rnBindSigs top_lev binders sigs `thenRn` \ siglist -> - flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) -> + flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> -- Do the SCC analysis - let edges = mkEdges mbinds_info + let edges = mkEdges (mbinds_info `zip` [0..]) scc_result = stronglyConnComp edges final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) @@ -280,19 +280,18 @@ rn_mono_binds top_lev binders mbinds sigs unique ``vertex tags'' on its output; minor plumbing required. \begin{code} -flattenMonoBinds :: Int -- Next free vertex tag - -> [RenamedSig] -- Signatures +flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds -> RnMS s (Int, [FlatMonoBindsInfo]) -flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, []) +flattenMonoBinds sigs EmptyMonoBinds = returnRn [] -flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) -> - flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) -> - returnRn (uniq2, flat1 ++ flat2) +flattenMonoBinds sigs (AndMonoBinds bs1 bs2) + = flattenMonoBinds sigs bs1 `thenRn` \ flat1 -> + flattenMonoBinds sigs bs2 `thenRn` \ flat2 -> + returnRn (flat1 ++ flat2) -flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) +flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn) = pushSrcLocRn locn $ rnPat pat `thenRn` \ pat' -> rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) -> @@ -303,17 +302,14 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me in - returnRn ( - uniq + 1, - [(uniq, - names_bound_here, + returnRn + [(names_bound_here, fvs `unionNameSets` sigs_fvs, PatMonoBind pat' grhss_and_binds' locn, sigs_for_me )] - ) -flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) +flattenMonoBinds sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf name) matches `thenRn_` lookupBndrRn name `thenRn` \ name' -> @@ -323,15 +319,12 @@ flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn) sigs_for_me = filter ((name' ==) . sig_name) sigs sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me in - returnRn ( - uniq + 1, - [(uniq, - unitNameSet name', + returnRn + [(unitNameSet name', fvs `unionNameSets` sigs_fvs, FunMonoBind name' inf new_matches locn, sigs_for_me )] - ) \end{code} @@ -417,23 +410,21 @@ renamed. \begin{code} type FlatMonoBindsInfo - = (VertexTag, -- Identifies the vertex - NameSet, -- Set of names defined in this vertex + = (NameSet, -- Set of names defined in this vertex NameSet, -- Set of names used in this vertex - RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat) + RenamedMonoBinds, [RenamedSig]) -- Signatures, if any, for this vertex - -mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] +mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] mkEdges flat_info = [ (info, tag, dest_vertices (nameSetToList names_used)) - | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info + | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info ] where -- An edge (v,v') indicates that v depends on v' dest_vertices src_mentions = [ target_vertex - | (target_vertex, names_defined, _, _, _) <- flat_info, + | ((names_defined, _, _, _), target_vertex) <- flat_info, mentioned_name <- src_mentions, mentioned_name `elemNameSet` names_defined ] diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index e744046..dff9abe 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,7 +12,7 @@ import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, isQual, qual + rdrNameOcc, isQual, qual, isClassDataConRdrName ) import HsTypes ( getTyVarName, replaceTyVarName ) import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) @@ -466,14 +466,14 @@ plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) \begin{code} plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv plusGlobalNameEnvRn env1 env2 - = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_` + = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_` returnRn (env1 `plusFM` env2) addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv addOneToGlobalNameEnv env rdr_name name = case lookupFM env rdr_name of Just name2 | conflicting_name name name2 - -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_` + -> addNameClashErrRn (rdr_name, (name, name2))) `thenRn_` returnRn env other -> returnRn (addToFM env rdr_name name) @@ -702,10 +702,18 @@ warnUnusedNames names unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used") -nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) +addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) + | isClassDataConRdrName rdr_name + -- Nasty hack to prevent error messages complain about conflicts for ":C", + -- where "C" is a class. There'll be a message about C, and :C isn't + -- the programmer's business. There may be a better way to filter this + -- out, but I couldn't get up the energy to find it. + = returnRn () + + | otherwise + = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) + 4 (vcat [ppr how_in_scope1, + ppr how_in_scope2]) fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 9ffa8e2..097cdd7 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -48,10 +48,10 @@ import Util ( removeDups ) \begin{code} getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, RnEnv, NameSet, Name -> PrintUnqualified)) - -- The NameSet is the set of names that are - -- either locally defined, - -- or explicitly imported + -> RnMG (Maybe (ExportEnv, + RnEnv, + FiniteMap Name HowInScope, -- Locally defined or explicitly imported + Name -> PrintUnqualified)) -- Nothing => no need to recompile getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) @@ -60,7 +60,7 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_avails) -> + importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_info) -> -- PROCESS IMPORT DECLS mapAndUnzip3Rn importsFromImportDecl all_imports @@ -98,23 +98,19 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) export_avails :: ExportAvails export_avails = foldr plusExportAvails local_mod_avails imp_avails_s - explicit_names :: NameSet -- locally defined or explicitly imported - explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s) - add_on avails names = foldr (unionNameSets . mkNameSet . availNames) names avails + explicit_info :: FiniteMap Name HowInScope -- Locally defined or explicitly imported + explicit_info = foldr plusFM local_info explicit_imports_s in exportsFromAvail this_mod exports export_avails rn_env `thenRn` \ (export_fn, export_env) -> - -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE - mapRn (recordSlurp Nothing Compulsory) local_avails `thenRn_` - -- BUILD THE "IMPORT FN". It just tells whether a name is in -- scope in an unqualified form. let print_unqual = mkImportFn imp_rn_env in - returnRn (export_fn, Just (export_env, rn_env, explicit_names, print_unqual)) + returnRn (export_fn, Just (export_env, rn_env, explicit_info, print_unqual)) ) `thenRn` \ (_, result) -> returnRn result where @@ -167,7 +163,9 @@ checkEarlyExit mod \begin{code} importsFromImportDecl :: RdrNameImportDecl - -> RnMG (RnEnv, ExportAvails, [AvailInfo]) + -> RnMG (RnEnv, + ExportAvails, + FiniteMap Name HowInScope) -- Records the explicitly-imported things importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc) = pushSrcLocRn loc $ @@ -175,6 +173,10 @@ importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> let how_in_scope = FromImportDecl mod loc + explicit_info = listToFM [(name, how_in_scope) + | avail <- explicits, + name <- availNames avail + ] in qualifyImports mod True -- Want qualified names @@ -184,14 +186,27 @@ importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc filtered_avails (\n -> how_in_scope) [ (occ,(fixity,how_in_scope)) | (occ,fixity) <- fixities ] `thenRn` \ (rn_env, mod_avails) -> - returnRn (rn_env, mod_avails, explicits) + returnRn (rn_env, mod_avails, explicit_info) \end{code} \begin{code} importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) = foldlRn getLocalDeclBinders [] decls `thenRn` \ avails -> + + -- Record that locally-defined things are available + mapRn (recordSlurp Nothing Compulsory) avails `thenRn_` + + -- Fixities mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities -> + + -- Record where the available stuff came from + let + explicit_info = listToFM [(name, FromLocalDefn (getSrcLoc name)) + | avail <- avails, + name <- availNames avail + ] + in qualifyImports mod False -- Don't want qualified names True -- Want unqualified names @@ -200,7 +215,7 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) avails (\n -> FromLocalDefn (getSrcLoc n)) fixities `thenRn` \ (rn_env, mod_avails) -> - returnRn (rn_env, mod_avails, avails) + returnRn (rn_env, mod_avails, explicit_info) where newLocalName rdr_name loc = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index b996b72..2340b23 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -38,7 +38,8 @@ import SimplMonad import SimplVar ( completeVar ) import Unique ( Unique ) import SimplUtils -import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, splitAlgTyConApp_maybe, +import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys, + mkFunTys, splitAlgTyConApp_maybe, splitFunTys, splitFunTy_maybe, isUnpointedType ) import TysPrim ( realWorldStatePrimTy ) @@ -507,7 +508,7 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> let new_tys = mkTyVarTys tyvars' - body_ty = foldl applyTy rhs_ty new_tys + body_ty = applyTys rhs_ty new_tys lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys) in -- Deal with the little lambda part diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 6bed59f..02bcc9d 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -26,7 +26,7 @@ import CoreUtils ( coreExprType, squashableDictishCcExpr ) import FiniteMap ( addListToFM_C, FiniteMap ) import Kind ( mkBoxedTypeKind, isBoxedTypeKind ) import Id ( idType, isDefaultMethodId_maybe, toplevelishId, - isSuperDictSelId_maybe, isBottomingId, + isBottomingId, isDataCon, isImportedId, mkIdWithNewUniq, dataConTyCon, applyTypeEnvToId, diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 6ff359b..d899c08 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -632,7 +632,7 @@ data InstOrigin s \begin{code} pprOrigin :: Inst s -> SDoc pprOrigin inst - = hsep [text "arising from", pp_orig orig <> comma, text "at", ppr locn] + = hsep [text "arising from", pp_orig orig, text "at", ppr locn] where (orig, locn) = case inst of Dict _ _ _ orig loc -> (orig,loc) @@ -659,11 +659,11 @@ pprOrigin inst = ptext SLIT("a class declaration") pp_orig (InstanceSpecOrigin clas ty) = hsep [text "a SPECIALIZE instance pragma; class", - ppr clas, text "type:", ppr ty] + quotes (ppr clas), text "type:", ppr ty] pp_orig (ValSpecOrigin name) - = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr name] + = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)] pp_orig (CCallOrigin clabel Nothing{-ccall result-}) - = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel] + = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)] pp_orig (CCallOrigin clabel (Just arg_expr)) = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, text "namely", quotes (ppr arg_expr)] diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 3889258..f058aac 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -6,7 +6,7 @@ \begin{code} module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, tcPragmaSigs, checkSigTyVars, tcBindWithSigs, - sigCtxt, sigThetaCtxt, TcSigInfo(..) ) where + sigCtxt, TcSigInfo(..) ) where #include "HsVersions.h" @@ -38,7 +38,7 @@ import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) import TcType ( TcType, TcThetaType, TcTauType, TcTyVarSet, TcTyVar, - newTyVarTy, newTcTyVar, tcInstSigType, + newTyVarTy, newTcTyVar, tcInstSigType, tcInstSigTcType, zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar ) import Unify ( unifyTauTy, unifyTauTyLists ) @@ -311,9 +311,9 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn -- Check that the needed dicts can be expressed in -- terms of the signature ones tcAddErrCtxt (bindSigsCtxt tysig_names) $ - tcAddErrCtxtM (sigThetaCtxt dicts_sig) $ tcSimplifyAndCheck - (text "tcBinds2" <+> ppr binder_names) + (ptext SLIT("type signature for") <+> + hsep (punctuate comma (map (quotes . ppr) binder_names))) real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) -> returnTc (lie_free, dict_binds, dict_ids) @@ -626,14 +626,26 @@ tcTySig :: (Name -> PragmaInfo) tcTySig prag_info_fn (Sig v ty src_loc) = tcAddSrcLoc src_loc $ tcHsType ty `thenTc` \ sigma_ty -> - tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> + + -- Convert from Type to TcType + tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty -> + let + poly_id = mkUserId v sigma_tc_ty (prag_info_fn v) + in + -- Instantiate this type + -- It's important to do this even though in the error-free case + -- we could just split the sigma_tc_ty (since the tyvars don't + -- unified with anything). But in the case of an error, when + -- the tyvars *do* get unified with something, we want to carry on + -- typechecking the rest of the program with the function bound + -- to a pristine type, namely sigma_tc_ty + tcInstSigTcType sigma_tc_ty `thenNF_Tc` \ (tyvars, rho) -> let - poly_id = mkUserId v sigma_ty' (prag_info_fn v) - (tyvars', theta', tau') = splitSigmaTy sigma_ty' + (theta, tau) = splitRhoTy rho -- This splitSigmaTy tries hard to make sure that tau' is a type synonym -- wherever possible, which can improve interface files. in - returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc) + returnTc (TySigInfo v poly_id tyvars theta tau src_loc) \end{code} @checkSigMatch@ does the next step in checking signature matching. @@ -982,10 +994,6 @@ badMatchErr sig_ty inferred_ty sigCtxt id = sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)] -sigThetaCtxt dicts_sig - = mapNF_Tc zonkInst (bagToList dicts_sig) `thenNF_Tc` \ dicts' -> - returnNF_Tc (ptext SLIT("Available context:") <+> pprInsts dicts') - bindSigsCtxt ids = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 818842c..2372f39 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -23,7 +23,7 @@ import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo, tcLookupClass, tcLookupTyVar, tcExtendGlobalTyVars ) -import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, sigThetaCtxt, TcSigInfo(..) ) +import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, TcSigInfo(..) ) import TcKind ( unifyKinds, TcKind ) import TcMonad import TcMonoType ( tcHsType, tcContext ) @@ -181,7 +181,14 @@ tcClassContext rec_class rec_tyvars context pragmas in -- Make super-class selector ids - mapTc mk_super_id sc_theta `thenTc` \ sc_sel_ids -> + -- We number them off, 1, 2, 3 etc so that we can construct + -- names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + mapTc mk_super_id (sc_theta `zip` [1..]) `thenTc` \ sc_sel_ids -> -- Done returnTc (sc_theta, sc_tys, sc_sel_ids) @@ -189,13 +196,13 @@ tcClassContext rec_class rec_tyvars context pragmas where rec_tyvar_tys = mkTyVarTys rec_tyvars - mk_super_id (super_class, tys) + mk_super_id ((super_class, tys), index) = tcGetUnique `thenNF_Tc` \ uniq -> let ty = mkForAllTys rec_tyvars $ mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys) in - returnTc (mkSuperDictSelId uniq rec_class super_class ty) + returnTc (mkSuperDictSelId uniq rec_class index ty) tcClassSig :: TcEnv s -- Knot tying only! @@ -428,9 +435,9 @@ tcDefaultMethodBinds clas default_binds avail_insts = this_dict in tcAddErrCtxt (classDeclCtxt clas) $ - tcAddErrCtxtM (sigThetaCtxt avail_insts) $ mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' -> - tcSimplifyAndCheck (text "classDecl") + tcSimplifyAndCheck + (ptext SLIT("class") <+> ppr clas) (mkTyVarSet clas_tyvars') avail_insts (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) -> diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 44964cf..0bd6e24 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -26,7 +26,7 @@ import BasicTypes ( RecFlag(..) ) import Inst ( Inst, InstOrigin(..), OverloadedLit(..), LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) -import TcBinds ( tcBindsAndThen, checkSigTyVars, sigThetaCtxt ) +import TcBinds ( tcBindsAndThen, checkSigTyVars ) import TcEnv ( TcIdOcc(..), tcInstId, tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, tcLookupGlobalValueByKey, newMonoIds, @@ -578,12 +578,11 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty -- Check overloading constraints newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) -> - tcAddErrCtxtM (sigThetaCtxt sig_dicts) ( - tcSimplifyAndCheck - (text "expr ty sig") + tcSimplifyAndCheck + (ptext SLIT("the type signature") <+> quotes (ppr sigma_sig)) (mkTyVarSet zonked_sig_tyvars) sig_dicts lie - ) `thenTc_` + `thenTc_` -- Now match the signature type with res_ty. -- We must not do this earlier, because res_ty might well @@ -694,12 +693,13 @@ tcArg :: RenamedHsExpr -- The function (for error messages) tcArg the_fun (arg, expected_arg_ty, arg_no) = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $ - tcPolyExpr arg expected_arg_ty + tcPolyExpr (ptext SLIT("argument type of") <+> quotes (ppr the_fun)) + arg expected_arg_ty -- tcPolyExpr is like tcExpr, except that the expected type -- can be a polymorphic one. -tcPolyExpr arg expected_arg_ty +tcPolyExpr str arg expected_arg_ty | not (maybeToBool (splitForAllTy_maybe expected_arg_ty)) = -- The ordinary, non-rank-2 polymorphic case tcExpr arg expected_arg_ty @@ -741,8 +741,8 @@ tcPolyExpr arg expected_arg_ty newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) -> -- ToDo: better origin - tcAddErrCtxtM (sigThetaCtxt sig_dicts) $ - tcSimplifyAndCheck (text "rank2") + tcSimplifyAndCheck + str (mkTyVarSet zonked_sig_tyvars) sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) -> @@ -999,7 +999,8 @@ tcRecordBinds expected_record_ty rbinds Just (record_ty, field_ty) = splitFunTy_maybe tau in unifyTauTy expected_record_ty record_ty `thenTc_` - tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) -> + tcPolyExpr (ptext SLIT("type of field") <+> quotes (ppr field_label)) + rhs field_ty `thenTc` \ (rhs', lie) -> returnTc ((RealId sel_id, rhs', pun_flag), lie) badFields rbinds data_con @@ -1083,7 +1084,7 @@ wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> ppr fun <+> ptext SLIT("is applied to") <+> text too_many_or_few <+> ptext SLIT("arguments in the call")) - 4 (ppr the_app) + 4 (parens (ppr the_app)) where the_app = foldl HsApp fun args -- Used in error messages diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5786837..18df0c8 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -25,12 +25,12 @@ import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr, maybeBoxedPrimType ) -import TcBinds ( tcPragmaSigs, sigThetaCtxt ) +import TcBinds ( tcPragmaSigs ) import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad import RnMonad ( RnNameSupply ) import Inst ( Inst, InstOrigin(..), - newDicts, LIE, emptyLIE, plusLIE ) + newDicts, LIE, emptyLIE, plusLIE, plusLIEs ) import PragmaInfo ( PragmaInfo(..) ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo ) @@ -374,46 +374,48 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys dfun_arg_dicts `plusLIE` sc_dicts `plusLIE` unionManyBags meth_lies - in - tcAddErrCtxt superClassCtxt $ - tcAddErrCtxtM (sigThetaCtxt sc_dicts) $ - - - -- Deal with the LIE arising from the method bindings - tcSimplifyAndCheck (text "inst decl1a") - inst_tyvars_set -- Local tyvars - avail_insts - (unionManyBags insts_needed_s) -- Need to get defns for all these - `thenTc` \ (const_lie1, op_binds) -> - -- Deal with the super-class bindings - -- Ignore errors because they come from the *next* tcSimplify - discardErrsTc ( - tcSimplifyAndCheck (text "inst decl1b") - 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 - ) `thenTc` \ (const_lie2, sc_binds) -> - + methods_lie = plusLIEs insts_needed_s + in -- 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. - tcSimplifyAndCheck (text "inst decl1c") + tcAddErrCtxt superClassCtxt ( + tcSimplifyAndCheck + (ptext SLIT("instance declaration context")) inst_tyvars_set -- Local tyvars inst_decl_dicts -- The instance dictionaries available sc_dicts -- The superclass dicationaries reqd - `thenTc_` - -- Ignore the result; we're only doing + ) `thenTc_` + -- 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 + 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) + ) `thenTc` \ (const_lie, lie_binds) -> + + -- Create the result bindings let - const_lie = const_lie1 `plusLIE` const_lie2 - lie_binds = op_binds `AndMonoBinds` sc_binds - dict_constr = classDataCon clas con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys') @@ -664,8 +666,8 @@ scrutiniseInstanceType clas inst_taus -- -- We flag this separately to give a more precise error msg. -- - (uniqueOf clas == cCallableClassKey && not constructors_visible) || - (uniqueOf clas == cReturnableClassKey && not constructors_visible) + (uniqueOf clas == cCallableClassKey || uniqueOf clas == cReturnableClassKey) + && is_alg_tycon_app && not constructors_visible = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau) | -- CCALL CHECK (b) @@ -678,20 +680,16 @@ scrutiniseInstanceType clas inst_taus -- DERIVING CHECK -- It is obviously illegal to have an explicit instance -- for something that we are also planning to `derive' - | clas `elem` (tyConDerivings inst_tycon) + | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon) = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau) -- Kind check will have ensured inst_taus is of length 1 - -- ALL TYPE VARIABLES => bad - | all isTyVarTy inst_taus - = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables")) - -- WITH HASKELL 1.4, MUST HAVE C (T a b c) - | not opt_GlasgowExts + | not opt_GlasgowExts && not (length inst_taus == 1 && - maybeToBool tyconapp_maybe && - not (isSynTyCon inst_tycon) && - all isTyVarTy arg_tys && + maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor + not (isSynTyCon tycon) && -- ...but not a synonym + all isTyVarTy arg_tys && -- Applied to type variables length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys -- This last condition checks that all the type variables are distinct ) @@ -704,14 +702,20 @@ scrutiniseInstanceType clas inst_taus = returnTc () where - tyconapp_maybe = splitTyConApp_maybe first_inst_tau - Just (inst_tycon, arg_tys) = tyconapp_maybe (first_inst_tau : _) = inst_taus - constructors_visible = - case splitAlgTyConApp_maybe first_inst_tau of - Just (_,_,[]) -> False - everything_else -> True + -- Stuff for algebraic or -> type + maybe_tycon_app = splitTyConApp_maybe first_inst_tau + Just (tycon, arg_tys) = maybe_tycon_app + + -- Stuff for an *algebraic* data type + alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau + -- The "Alg" part looks through synonyms + is_alg_tycon_app = maybeToBool alg_tycon_app_maybe + Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe + + constructors_visible = not (null data_cons) + -- These conditions come directly from what the DsCCall is capable of. -- Totally grotesque. Green card should solve this. @@ -778,5 +782,6 @@ invisibleDataConPrimCCallErr clas inst_ty 4 (hsep [text "(Try either importing", ppr inst_ty, text "non-abstractly or compile using -fno-prune-tydecls ..)"]) -superClassCtxt = ptext SLIT("From the superclasses of the instance declaration") +methodCtxt = ptext SLIT("When checking the methods of an instance declaration") +superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 02552da..3fe3ac5 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -278,7 +278,7 @@ addErrTc err_msg down env listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let err = addShortErrLocLine loc $ - hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs)) + vcat (err_msg : ctxt_to_use ctxt_msgs) in writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` returnSST () @@ -294,7 +294,7 @@ warnTc warn_if_true warn_msg down env listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let warn = addShortWarnLocLine loc $ - hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs)) + vcat (warn_msg : ctxt_to_use ctxt_msgs) in writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` returnSST () diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index aec75e7..ed35d08 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -96,15 +96,7 @@ tc_hs_type_kind (HsForAllTy tv_names context ty) -- for unfoldings, and instance decls, only: tc_hs_type_kind (MonoDictTy class_name tys) - = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> - tcLookupClass class_name `thenTc` \ (class_kinds, clas) -> - let - arity = length class_kinds - n_args = length arg_kinds - err = arityErr "Class" class_name arity n_args - in - checkTc (arity == n_args) err `thenTc_` - unifyKinds class_kinds arg_kinds `thenTc_` + = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) -> returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys) \end{code} @@ -167,34 +159,44 @@ Contexts \begin{code} tcContext :: RenamedContext -> TcM s ThetaType -tcContext context = tcAddErrCtxt (thetaCtxt context) $ - mapTc tcClassAssertion context +tcContext context + = tcAddErrCtxt (thetaCtxt context) $ + + --Someone discovered that @CCallable@ and @CReturnable@ + -- could be used in contexts such as: + -- foo :: CCallable a => a -> PrimIO Int + -- Doing this utterly wrecks the whole point of introducing these + -- classes so we specifically check that this isn't being done. + -- + -- We *don't* do this check in tcClassAssertion, because that's + -- called when checking a HsDictTy, and we don't want to reject + -- instance CCallable Int + -- etc. Ugh! + mapTc check_naughty context `thenTc_` + + mapTc tcClassAssertion context + + where + check_naughty (class_name, _) + = checkTc (not (uniqueOf class_name `elem` cCallishClassKeys)) + (naughtyCCallContextErr class_name) tcClassAssertion (class_name, tys) - = checkTc (canBeUsedInContext class_name) - (naughtyCCallContextErr class_name) `thenTc_` - - tcLookupClass class_name `thenTc` \ (class_kinds, clas) -> + = tcLookupClass class_name `thenTc` \ (class_kinds, clas) -> mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) -> + -- Check with kind mis-match + let + arity = length class_kinds + n_tys = length ty_kinds + err = arityErr "Class" class_name arity n_tys + in + checkTc (arity == n_tys) err `thenTc_` unifyKinds class_kinds ty_kinds `thenTc_` returnTc (clas, tc_tys) \end{code} -HACK warning: Someone discovered that @CCallable@ and @CReturnable@ -could be used in contexts such as: -\begin{verbatim} -foo :: CCallable a => a -> PrimIO Int -\end{verbatim} - -Doing this utterly wrecks the whole point of introducing these -classes so we specifically check that this isn't being done. - -\begin{code} -canBeUsedInContext :: Name -> Bool -canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys) -\end{code} Type variables, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 8f7451c..061b09a 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -24,13 +24,14 @@ import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import Maybes ( maybeToBool ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) import Id ( GenId, idType, Id ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) import PprType ( GenType, GenTyVar ) import Type ( splitFunTys, splitRhoTy, - splitFunTy_maybe, + splitFunTy_maybe, splitAlgTyConApp_maybe, Type, GenType ) import TyVar ( GenTyVar ) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 0de237d..2cd1458 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -184,13 +184,40 @@ tcSimplify :: SDoc -> TopLevelFlag -> TcTyVarSet s -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked -> LIE s -- Wanted -> TcM s (LIE s, -- Free TcDictBinds s, -- Bindings LIE s) -- Remaining wanteds; no dups -tcSimplify str top_lvl local_tvs wanteds - = tcSimpl str top_lvl local_tvs Nothing wanteds +tcSimplify str top_lvl local_tvs wanted_lie + = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> + + -- Check for non-generalisable insts + let + cant_generalise = filter (not . instCanBeGeneralised) irreds + in + checkTc (null cant_generalise) + (genCantGenErr cant_generalise) `thenTc_` + + -- Finished + returnTc (mkLIE frees, binds, mkLIE irreds) + where + wanteds = bagToList wanted_lie + + try_me inst + -- Does not constrain a local tyvar + | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs) + = -- if is_top_level then + -- FreeIfTautological -- Special case for inference on + -- -- top-level defns + -- else + Free + + -- We're infering (not checking) the type, and + -- the inst constrains a local type variable + | isDict inst = DontReduce -- Dicts + | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @tcSimplifyAndCheck@ is similar to the above, except that it checks @@ -200,85 +227,40 @@ some of constant insts, which have to be resolved finally at the end. \begin{code} tcSimplifyAndCheck :: SDoc - -> TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint - -> LIE s -- Given + -> TcTyVarSet s -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked + -> LIE s -- Given; constrain only local tyvars -> LIE s -- Wanted -> TcM s (LIE s, -- Free TcDictBinds s) -- Bindings -tcSimplifyAndCheck str local_tvs givens wanteds - = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) -> - ASSERT( isEmptyBag new_wanteds ) - returnTc (free_insts, binds) - where - top_lvl = error "tcSimplifyAndCheck" -- Never needed -\end{code} - -\begin{code} -tcSimpl :: SDoc - -> TopLevelFlag - -> TcTyVarSet s -- ``Local'' type variables - -- ASSERT: this tyvar set is already zonked - -> Maybe (LIE s) -- Given; these constrain only local tyvars - -- Nothing => just simplify - -- Just g => check that g entails wanteds - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcMonoBinds s, -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie - = -- ASSSERT: local_tvs are already zonked - reduceContext str try_me - givens - (bagToList wanted_lie) `thenTc` \ (binds, frees, irreds) -> +tcSimplifyAndCheck str local_tvs given_lie wanted_lie + = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) -> - -- Check for non-generalisable insts - let - cant_generalise = filter (not . instCanBeGeneralised) irreds - in - checkTc (null cant_generalise) - (genCantGenErr cant_generalise) `thenTc_` + -- Complain about any irreducible ones + mapNF_Tc complain irreds `thenNF_Tc_` - -- Finished - returnTc (mkLIE frees, binds, mkLIE irreds) + -- Done + returnTc (mkLIE frees, binds) where - givens = case maybe_given_lie of - Just given_lie -> bagToList given_lie - Nothing -> [] - - checking_against_signature = maybeToBool maybe_given_lie - is_top_level = case top_lvl of { TopLevel -> True; other -> False } + givens = bagToList given_lie + wanteds = bagToList wanted_lie try_me inst -- Does not constrain a local tyvar - | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs) - = -- if not checking_against_signature && is_top_level then - -- FreeIfTautological -- Special case for inference on - -- -- top-level defns - -- else - - Free + | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs) + = Free -- When checking against a given signature we always reduce -- until we find a match against something given, or can't reduce - | checking_against_signature - = ReduceMe CarryOn - - -- So we're infering (not checking) the type, and - -- the inst constrains a local type variable | otherwise - = if isDict inst then - DontReduce -- Dicts - else - ReduceMe CarryOn -- Lits and Methods + = ReduceMe AddToIrreds - where - inst_tyvars = tyVarsOfInst inst + complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> + addNoInstanceErr str givens dict \end{code} - %************************************************************************ %* * \subsection{Data types for the reduction mechanism} @@ -289,7 +271,7 @@ The main control over context reduction is here \begin{code} data WhatToDo - = ReduceMe -- Reduce this + = ReduceMe -- Try to reduce this NoInstanceAction -- What to do if there's no such instance | DontReduce -- Return as irreducible @@ -300,14 +282,12 @@ data WhatToDo -- if not, return as irreducible data NoInstanceAction - = CarryOn -- Produce an error message, but keep on with next inst - - | Stop -- Produce an error message and stop reduction + = Stop -- Fail; no error message + -- (Only used when tautology checking.) | AddToIrreds -- Just add the inst to the irreductible ones; don't -- produce an error message of any kind. - -- It might be quite legitimate - -- such as (Eq a)! + -- It might be quite legitimate such as (Eq a)! \end{code} @@ -387,7 +367,9 @@ The main entry point for context reduction is @reduceContext@: reduceContext :: SDoc -> (Inst s -> WhatToDo) -> [Inst s] -- Given -> [Inst s] -- Wanted - -> TcM s (TcDictBinds s, [Inst s], [Inst s]) + -> TcM s (TcDictBinds s, + [Inst s], -- Free + [Inst s]) -- Irreducible reduceContext str try_me givens wanteds = -- Zonking first @@ -484,21 +466,8 @@ reduce try_me (wanted:wanteds) state@(avails, frees, irreds) NoInstance -> -- No such instance! -- Decide what to do based on the no_instance_action requested case no_instance_action of - Stop -> -- Fail - addNoInstanceErr wanted `thenNF_Tc_` - failTc - - CarryOn -> -- Carry on. - -- Add the bad guy to the avails to suppress similar - -- messages from other insts in wanteds - addNoInstanceErr wanted `thenNF_Tc_` - addGiven avails wanted `thenNF_Tc` \ avails' -> - reduce try_me wanteds (avails', frees, irreds) -- Carry on - - AddToIrreds -> -- Add the offending insts to the irreds - add_to_irreds - - + Stop -> failTc -- Fail + AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds -- It's free and this isn't a top-level binding, so just chuck it upstairs | case try_me_result of { Free -> True; _ -> False } @@ -709,8 +678,6 @@ tcSimplifyCheckThetas givens wanteds else mapNF_Tc addNoInstErr irreds `thenNF_Tc_` failTc - -addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts) \end{code} @@ -813,7 +780,7 @@ bindInstsOfLocalFuns init_lie local_ids local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them -- so it's worth building a set, so that -- lookup (in isMethodFor) is faster - try_me inst | isMethodFor local_id_set inst = ReduceMe CarryOn + try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds | otherwise = Free \end{code} @@ -860,8 +827,8 @@ all the constant and ambiguous Insts. \begin{code} tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) -tcSimplifyTop wanteds - = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds) `thenTc` \ (binds1, frees, irreds) -> +tcSimplifyTop wanted_lie + = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) let @@ -892,11 +859,12 @@ tcSimplifyTop wanteds returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig) where - try_me inst = ReduceMe AddToIrreds + wanteds = bagToList wanted_lie + try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d + complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d | otherwise = addAmbigErr [d] get_tv d = case getDictClassTys d of @@ -968,7 +936,7 @@ disambigGroup dicts returnTc EmptyMonoBinds where - try_me inst = ReduceMe CarryOn + try_me inst = ReduceMe AddToIrreds -- This reduce should not fail tyvar = get_tv (head dicts) -- Should be non-empty classes = map get_clas dicts \end{code} @@ -992,20 +960,28 @@ addAmbigErr dicts addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts, nest 4 (pprInstsInFull dicts)]) -addNoInstanceErr dict +-- Used for top-level irreducibles +addTopInstanceErr dict = tcAddSrcLoc (instLoc dict) $ - tcAddErrCtxt (pprOrigin dict) $ - addErrTc (noDictInstanceErr clas tys) + addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict), + nest 4 $ parens $ pprOrigin dict]) + +addNoInstanceErr str givens dict + = tcAddSrcLoc (instLoc dict) $ + addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict), + nest 4 $ parens $ pprOrigin dict], + nest 4 $ ptext SLIT("from the context") <+> pprInsts givens] + $$ + ptext SLIT("Probable cause:") <+> + vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str, + if all_tyvars then empty else + ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)] + ) where - (clas, tys) = getDictClassTys dict + all_tyvars = all isTyVarTy tys + (_, tys) = getDictClassTys dict -noDictInstanceErr clas tys - = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys) - -reduceSigCtxt lie - = sep [ptext SLIT("When matching against a type signature with context"), - nest 4 (quotes (pprInsts (bagToList lie))) - ] +-- Used for the ...Thetas variants; all top level +addNoInstErr (c,ts) + = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts)) \end{code} - - diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 9cb4112..1c35bda 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -233,6 +233,9 @@ tcInstSigType ty_to_inst where bind_fn = inst_sig_tyvar -- Note: inst_sig_tyvar, not inst_tyvar -- I don't think that can lead to strange error messages + -- of the form can't match (T a) against (T a) + -- See notes with inst_tyvar + occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty Nothing -> panic "tcInstType:2"-- (vcat [ppr ty_to_inst, diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 077aed6..43ce1f2 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -380,6 +380,7 @@ uTysX :: Type -> Type -> Subst -> Maybe Subst +uTysX (SynTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst uTysX ty1 (SynTy _ ty2) k subst = uTysX ty1 ty2 k subst -- Variables; go for uVar diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 0b9b294..b52b884 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -14,7 +14,8 @@ module Type ( mkSynTy, isSynTy, - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + applyTy, applyTys, TauType, RhoType, SigmaType, ThetaType, isTauTy, @@ -56,7 +57,7 @@ import BasicTypes ( Unused ) import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) import Unique -- quite a few *Keys -import Util ( thenCmp, panic ) +import Util ( thenCmp, panic, assertPanic ) \end{code} @@ -255,7 +256,7 @@ splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == l splitAlgTyConApp (SynTy _ ty) = splitAlgTyConApp ty \end{code} -y"Dictionary" types are just ordinary data types, but you can +"Dictionary" types are just ordinary data types, but you can tell from the type constructor whether it's a dictionary or not. \begin{code} @@ -346,6 +347,15 @@ applyTy :: GenType flexi -> GenType flexi -> GenType flexi applyTy (SynTy _ fun) arg = applyTy fun arg applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty applyTy other arg = panic "applyTy" + +applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi +applyTys fun_ty arg_tys + = go [] fun_ty arg_tys + where + go env ty [] = instantiateTy (mkTyVarEnv env) ty + go env (SynTy _ fun) args = go env fun args + go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args + go env other args = panic "applyTys" \end{code} -- 1.7.10.4