Commit b473b6c2 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-05-03 09:32:48 by simonpj]

------------------------------------------------
	Dramatically improve the error messages arising
	from failed unifications triggered by 'improvement'
	------------------------------------------------

A bit more plumbing in FunDeps, and consequential wibbles elsewhere

Changes this:

    Couldn't match `Int' against `[(String, Int)]'
	Expected type: Int
	Inferred type: [(String, Int)]

to this:

    Foo.hs:8:
	Couldn't match `Int' against `[(String, Int)]'
	    Expected type: Int
	    Inferred type: [(String, Int)]
	When using functional dependencies to combine
	  ?env :: Int, arising from a type signature at Foo.hs:7
	  ?env :: [(String, Int)],
	    arising from use of implicit parameter `?env' at Foo.hs:8
	When generalising the types for ident
parent 0f7c4b88
......@@ -229,6 +229,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
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) ->
......@@ -482,8 +484,9 @@ generalise binder_names mbind tau_tvs lie_req sigs
-- 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
......@@ -501,8 +504,7 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
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)
......@@ -824,6 +826,9 @@ restrictedBindCtxtErr binder_names
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}
......@@ -51,7 +51,7 @@ import Type ( Type, ThetaType, PredType, mkClassPred,
mkTyVarTy, getTyVar, isTyVarClassPred,
splitSigmaTy, tyVarsOfPred,
getClassPredTys_maybe, isClassPred, isIPPred,
inheritablePred
inheritablePred, predHasFDs
)
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
......@@ -968,7 +968,12 @@ reduceContext doc try_me givens wanteds
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)
......@@ -983,10 +988,14 @@ tcImprove avails
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.
......
......@@ -10,7 +10,8 @@ module Class (
mkClass, classTyVars, classArity,
classKey, className, classSelIds, classTyCon,
classBigSig, classExtraBigSig, classTvsFds, classSCTheta
classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
classHasFDs
) where
#include "HsVersions.h"
......@@ -113,6 +114,9 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
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}
......
......@@ -12,14 +12,15 @@ module FunDeps (
#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 )
......@@ -143,7 +144,7 @@ grow preds fixed_tvs
\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
......@@ -151,14 +152,16 @@ type Equation = (TyVarSet, Type,Type) -- These two types should be equal, for so
-- 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
......@@ -199,18 +202,18 @@ NOTA BENE:
\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 ...
......@@ -232,23 +235,31 @@ checkGroup inst_env clss@(ClassP cls tys : _)
-- 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
......
......@@ -51,7 +51,7 @@ module Type (
-- 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,
......@@ -102,7 +102,7 @@ import VarSet
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,
......@@ -714,6 +714,12 @@ predMentionsIPs :: PredType -> NameSet -> Bool
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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment