in
-- GENERALISE
+ tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $
+ tcAddErrCtxt (genCtxt binder_names) $
generalise binder_names mbind tau_tvs lie_req tc_ty_sigs
`thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) ->
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
-checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
- = mapTc_ check_one other_sigs `thenTc_`
+checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
+ = tcAddSrcLoc src_loc $
+ mapTc_ check_one other_sigs `thenTc_`
if null theta1 then
returnTc ([], []) -- Non-overloaded type signatures
else
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (sigContextsCtxt id1 id) $
+ = tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
ptext SLIT("that falls under the monomorphism restriction")])
+genCtxt binder_names
+ = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
-- Used in error messages
pprBinders bndrs = pprWithCommas ppr bndrs
\end{code}
mkTyVarTy, getTyVar, isTyVarClassPred,
splitSigmaTy, tyVarsOfPred,
getClassPredTys_maybe, isClassPred, isIPPred,
- inheritablePred
+ inheritablePred, predHasFDs
)
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
tcImprove avails
= tcGetInstEnv `thenTc` \ inst_env ->
let
- preds = predsOfInsts (keysFM avails)
+ preds = [ (pred, pp_loc)
+ | inst <- keysFM avails,
+ let pp_loc = pprInstLoc (instLoc inst),
+ pred <- predsOfInst inst,
+ predHasFDs pred
+ ]
-- Avails has all the superclasses etc (good)
-- It also has all the intermediates of the deduction (good)
-- It does not have duplicates (good)
mapTc_ unify eqns `thenTc_`
returnTc False
where
- unify (qtvs, t1, t2) = tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
- unifyTauTy (substTy tenv t1) (substTy tenv t2)
- ppr_eqn (qtvs, t1, t2) = ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)) <+>
- ppr t1 <+> equals <+> ppr t2
+ unify ((qtvs, t1, t2), doc)
+ = tcAddErrCtxt doc $
+ tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv t2)
+ ppr_eqn ((qtvs, t1, t2), doc)
+ = vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs))
+ <+> ppr t1 <+> equals <+> ppr t2,
+ doc]
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
mkClass, classTyVars, classArity,
classKey, className, classSelIds, classTyCon,
- classBigSig, classExtraBigSig, classTvsFds, classSCTheta
+ classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
+ classHasFDs
) where
#include "HsVersions.h"
classSCTheta = sc_theta, classSCSels = sc_sels,
classOpStuff = op_stuff})
= (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
+
+classHasFDs :: Class -> Bool
+classHasFDs (Class {classFunDeps = fundeps}) = not (null fundeps)
\end{code}
#include "HsVersions.h"
-import Var ( TyVar )
+import Name ( getSrcLoc )
+import Var ( Id, TyVar )
import Class ( Class, FunDep, classTvsFds )
-import Type ( Type, ThetaType, PredType(..), predTyUnique, tyVarsOfTypes, tyVarsOfPred )
+import Type ( Type, ThetaType, PredType(..), predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred )
import Subst ( mkSubst, emptyInScopeSet, substTy )
import Unify ( unifyTyListsX, unifyExtendTysX )
-import Outputable ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
import VarSet
import VarEnv
+import Outputable
import List ( tails )
import Maybes ( maybeToBool )
import ListSetOps ( equivClassesByUniq )
\begin{code}
----------
-type Equation = (TyVarSet, Type,Type) -- These two types should be equal, for some
+type Equation = (TyVarSet, Type, Type) -- These two types should be equal, for some
-- substitution of the tyvars in the tyvar set
-- For example, ({a,b}, (a,Int,b), (Int,z,Bool))
-- We unify z with Int, but since a and b are quantified we do nothing to them
-- to fresh type variables, and then calling the standard unifier.
--
-- INVARIANT: they aren't already equal
+ --
----------
-improve :: InstEnv a -- Gives instances for given class
- -> [PredType] -- Current constraints
- -> [Equation] -- Derived equalities that must also hold
+improve :: InstEnv Id -- Gives instances for given class
+ -> [(PredType,SDoc)] -- Current constraints; doc says where they come from
+ -> [(Equation,SDoc)] -- Derived equalities that must also hold
-- (NB the above INVARIANT for type Equation)
+ -- The SDoc explains why the equation holds (for error messages)
type InstEnv a = Class -> [(TyVarSet, [Type], a)]
-- This is a bit clumsy, because InstEnv is really
\begin{code}
improve inst_env preds
- = [ eqn | group <- equivClassesByUniq predTyUnique preds,
+ = [ eqn | group <- equivClassesByUniq (predTyUnique . fst) preds,
eqn <- checkGroup inst_env group ]
----------
-checkGroup :: InstEnv a -> [PredType] -> [Equation]
+checkGroup :: InstEnv Id -> [(PredType,SDoc)] -> [(Equation, SDoc)]
-- The preds are all for the same class or implicit param
-checkGroup inst_env (IParam _ ty : ips)
+checkGroup inst_env (p1@(IParam _ ty, _) : ips)
= -- For implicit parameters, all the types must match
- [(emptyVarSet, ty, ty') | IParam _ ty' <- ips, ty /= ty']
+ [((emptyVarSet, ty, ty'), mkEqnMsg p1 p2) | p2@(IParam _ ty', _) <- ips, ty /= ty']
-checkGroup inst_env clss@(ClassP cls tys : _)
+checkGroup inst_env clss@((ClassP cls _, _) : _)
= -- For classes life is more complicated
-- Suppose the class is like
-- classs C as | (l1 -> r1), (l2 -> r2), ... where ...
-- NOTE that we iterate over the fds first; they are typically
-- empty, which aborts the rest of the loop.
- pairwise_eqns :: [Equation]
+ pairwise_eqns :: [(Equation,SDoc)]
pairwise_eqns -- This group comes from pairwise comparison
- = [ eqn | fd <- cls_fds,
- ClassP _ tys1 : rest <- tails clss,
- ClassP _ tys2 <- rest,
- eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2
+ = [ (eqn, mkEqnMsg p1 p2)
+ | fd <- cls_fds,
+ p1@(ClassP _ tys1, _) : rest <- tails clss,
+ p2@(ClassP _ tys2, _) <- rest,
+ eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2
]
- instance_eqns :: [Equation]
+ instance_eqns :: [(Equation,SDoc)]
instance_eqns -- This group comes from comparing with instance decls
- = [ eqn | fd <- cls_fds,
- (qtvs, tys1, _) <- cls_inst_env,
- ClassP _ tys2 <- clss,
- eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2
+ = [ (eqn, mkEqnMsg p1 p2)
+ | fd <- cls_fds,
+ (qtvs, tys1, dfun_id) <- cls_inst_env,
+ let p1 = (mkClassPred cls tys1,
+ ptext SLIT("arising from the instance declaration at") <+> ppr (getSrcLoc dfun_id)),
+ p2@(ClassP _ tys2, _) <- clss,
+ eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2
]
-
+mkEqnMsg (pred1,from1) (pred2,from2)
+ = vcat [ptext SLIT("When using functional dependencies to combine"),
+ nest 2 (sep [ppr pred1 <> comma, nest 2 from1]),
+ nest 2 (sep [ppr pred2 <> comma, nest 2 from2])]
+
----------
checkClsFD :: TyVarSet -- The quantified type variables, which
-- can be instantiated to make the types match
-- Predicates and the like
PredType(..), getClassPredTys_maybe, getClassPredTys,
- isPredTy, isClassPred, isTyVarClassPred,
+ isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique,
splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
import OccName ( mkDictOcc )
import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
-import Class ( classTyCon, Class )
+import Class ( classTyCon, classHasFDs, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
predMentionsIPs other ns = False
+predHasFDs :: PredType -> Bool
+-- True if the predicate has functional depenencies;
+-- I.e. should participate in improvement
+predHasFDs (IParam _ _) = True
+predHasFDs (ClassP cls _) = classHasFDs cls
+
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
mkPredTy (ClassP clas tys)
projects / ghc-hetmet.git / commitdiff