Commit 7bb06950 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-07-07 12:13:43 by simonpj]

This commit moves the instance environment out of the Class data
structure, where it was immutable, to part of the type-checker
environment.  This change is absolutely essential as part of
our move to GHCi, and I think it's also going to be necessary
for Andrei's work on generic functions.

As part of this change, we can remove

  a) types/InstEnv.*	(thereby also removing a hi-boot loop)
  b) a tc-fixpoint-loop in TcModule

Both of these are worthwhile simplifications.
parent ec459c23
......@@ -12,7 +12,7 @@ then
then
VarEnv, VarSet, ThinAir
then
Class (loop TyCon.TyCon, loop Type.Type, loop InstEnv.InstEnv)
Class (loop TyCon.TyCon, loop Type.Type)
then
TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon)
then
......@@ -23,8 +23,6 @@ then
Unify, PprType (PprEnv)
then
Literal (TysPrim, PprType), DataCon
then
InstEnv (Unify)
then
TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId)
then
......
......@@ -11,8 +11,6 @@ module Inst (
Inst, OverloadedLit(..),
pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
InstanceMapper,
newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
newMethod, newMethodWithGivenTy, newOverloadedLit,
newIPDict, instOverloadedFun,
......@@ -45,21 +43,22 @@ import TcHsSyn ( TcExpr, TcId,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcMonad
import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
import TcEnv ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
tcLookupValueByKey, tcLookupTyConByKey
)
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
zonkTcTyVars, zonkTcType, zonkTcTypes,
zonkTcThetaType
)
import Bag
import Class ( classInstEnv, Class, FunDep )
import Class ( Class, FunDep )
import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
getOccName, nameUnique )
import PprType ( pprPred )
import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import SrcLoc ( SrcLoc )
import Type ( Type, PredType(..), ThetaType,
mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
......@@ -67,7 +66,6 @@ import Type ( Type, PredType(..), ThetaType,
splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
mkSynTy, tidyOpenType, tidyOpenTypes
)
import InstEnv ( InstEnv )
import Subst ( emptyInScopeSet, mkSubst,
substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
)
......@@ -285,6 +283,7 @@ Predicates
isDict :: Inst -> Bool
isDict (Dict _ _ _) = True
isDict other = False
isClassDict :: Inst -> Bool
isClassDict (Dict _ (Class _ _) _) = True
isClassDict other = False
......@@ -294,10 +293,8 @@ isMethod (Method _ _ _ _ _ _) = True
isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ _ loc)
= id `elemVarSet` ids
isMethodFor ids inst
= False
isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
isMethodFor ids inst = False
isTyVarDict :: Inst -> Bool
isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
......@@ -628,25 +625,6 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
%* *
%************************************************************************
\begin{code}
type InstanceMapper = Class -> InstEnv
\end{code}
A @ClassInstEnv@ lives inside a class, and identifies all the instances
of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
that instance.
There is an important consistency constraint between the @MatchEnv@s
in and the dfun @Id@s inside them: the free type variables of the
@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
contain the following entry:
@
[a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
@
The "a" in the pattern must be one of the forall'd variables in
the dfun type.
\begin{code}
data LookupInstResult s
= NoInstance
......@@ -659,7 +637,8 @@ lookupInst :: Inst
-- Dictionaries
lookupInst dict@(Dict _ (Class clas tys) loc)
= case lookupInstEnv (classInstEnv clas) tys of
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
FoundInst tenv dfun_id
-> let
......@@ -754,13 +733,13 @@ appropriate dictionary if it exists. It is used only when resolving
ambiguous dictionaries.
\begin{code}
lookupSimpleInst :: InstEnv
-> Class
lookupSimpleInst :: Class
-> [Type] -- Look up (c,t)
-> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys
= case lookupInstEnv class_inst_env tys of
lookupSimpleInst clas tys
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
FoundInst tenv dfun
-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
where
......@@ -769,3 +748,5 @@ lookupSimpleInst class_inst_env clas tys
other -> returnNF_Tc Nothing
\end{code}
......@@ -140,7 +140,7 @@ kcClassDecl (ClassDecl context class_name
%************************************************************************
\begin{code}
tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
tcClassDecl1 rec_env rec_vrcs
(ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas
tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
......@@ -166,11 +166,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
-- MAKE THE CLASS OBJECT ITSELF
let
(op_tys, op_items) = unzip sig_stuff
rec_class_inst_env = rec_inst_mapper rec_class
clas = mkClass class_name tyvars fds
sc_theta sc_sel_ids op_items
tycon
rec_class_inst_env
dict_component_tys = sc_tys ++ op_tys
new_or_data = case dict_component_tys of
......
......@@ -16,10 +16,9 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad
import Inst ( InstanceMapper )
import TcEnv ( getEnvTyCons )
import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv )
import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), buildInstanceEnvs )
import TcInstUtil ( InstInfo(..), buildInstanceEnv )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
......@@ -422,15 +421,15 @@ solveDerivEqns inst_decl_infos_in orig_eqns
-- with the current set of solutions, giving a
add_solns inst_decl_infos_in orig_eqns current_solns
`thenNF_Tc` \ (new_inst_infos, inst_mapper) ->
let
class_to_inst_env cls = inst_mapper cls
in
`thenNF_Tc` \ (new_inst_infos, inst_env) ->
-- Simplify each RHS
listTc [ tcAddErrCtxt (derivCtxt tc) $
tcSimplifyThetas class_to_inst_env deriv_rhs
| (_,tc,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
tcSetInstEnv inst_env (
listTc [ tcAddErrCtxt (derivCtxt tc) $
tcSimplifyThetas deriv_rhs
| (_,tc,_,deriv_rhs) <- orig_eqns ]
) `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns
......@@ -443,18 +442,18 @@ solveDerivEqns inst_decl_infos_in orig_eqns
add_solns :: Bag InstInfo -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln]
-> NF_TcM s ([InstInfo], -- The new, derived ones
InstanceMapper)
InstEnv)
-- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance.
add_solns inst_infos_in eqns solns
= discardErrsTc (buildInstanceEnvs all_inst_infos) `thenNF_Tc` \ inst_mapper ->
= discardErrsTc (buildInstanceEnv all_inst_infos) `thenNF_Tc` \ inst_env ->
-- We do the discard-errs so that we don't get repeated error messages
-- about duplicate instances.
-- They'll appear later, when we do the top-level buildInstanceEnvs.
-- They'll appear later, when we do the top-level buildInstanceEnv.
returnNF_Tc (new_inst_infos, inst_mapper)
returnNF_Tc (new_inst_infos, inst_env)
where
new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
......
This diff is collapsed.
......@@ -4,17 +4,16 @@ module TcImprove ( tcImprove ) where
#include "HsVersions.h"
import Name ( Name )
import Class ( Class, FunDep, className, classInstEnv, classExtraBigSig )
import Class ( Class, FunDep, className, classExtraBigSig )
import Unify ( unifyTyListsX, matchTys )
import Subst ( mkSubst, substTy )
import TcEnv ( tcGetInstEnv, classInstEnv )
import TcMonad
import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( LIE, Inst, LookupInstResult(..),
lookupInst, getFunDepsOfLIE, getIPsOfLIE,
zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
import VarSet ( VarSet, emptyVarSet, unionVarSet )
import VarEnv ( emptyVarEnv )
import FunDeps ( instantiateFdClassTys )
......@@ -26,44 +25,41 @@ import List ( elemIndex, nub )
tcImprove :: LIE -> TcM s ()
-- Do unifications based on functional dependencies in the LIE
tcImprove lie
| null nfdss = returnTc ()
| otherwise = iterImprove nfdss
where
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
let
nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
cfdss :: [(Class, [FunDep TcType])]
cfdss = getFunDepsOfLIE lie
clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
cfdss = getFunDepsOfLIE lie
clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
classes = nub (map fst cfdss)
inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
| c <- classes,
(free, ts, i) <- classInstEnv inst_env c
]
ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
{- Example: we have
class C a b c | a->b where ...
instance C Int Bool c
Given the LIE FD C (Int->t)
we get clas_nfdss = [({}, C, [Int->t, t->Int])
inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
Another way would be to flatten a bit
we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
iterImprove then matches up the C and Int, and unifies t <-> Bool
-}
in
iterImprove nfdss
classes = nub (map fst cfdss)
inst_nfdss = concatMap getInstNfdssOf classes
ips = getIPsOfLIE lie
ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
{- Example: we have
class C a b c | a->b where ...
instance C Int Bool c
Given the LIE FD C (Int->t)
we get clas_nfdss = [({}, C, [Int->t, t->Int])
inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
Another way would be to flatten a bit
we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
iterImprove then matches up the C and Int, and unifies t <-> Bool
-}
getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])]
getInstNfdssOf clas
= [ (free, nm, instantiateFdClassTys clas ts)
| (free, ts, i) <- classInstEnv clas
]
where
nm = className clas
iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
iterImprove [] = returnTc ()
......
......@@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv.
\begin{code}
module TcInstUtil (
InstInfo(..),
buildInstanceEnvs,
buildInstanceEnv,
classDataCon
) where
......@@ -18,12 +18,10 @@ import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import CmdLineOpts ( opt_AllowOverlappingInstances )
import TcMonad
import Inst ( InstanceMapper )
import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Bag ( bagToList, Bag )
import Class ( Class )
import Var ( TyVar, Id, idName )
import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, nameModule, isLocallyDefined )
import SrcLoc ( SrcLoc )
......@@ -77,32 +75,9 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
%************************************************************************
\begin{code}
buildInstanceEnvs :: Bag InstInfo
-> NF_TcM s InstanceMapper
buildInstanceEnvs info
= let
i_uniq :: InstInfo -> Unique
i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
info_by_class = equivClassesByUniq i_uniq (bagToList info)
in
mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries ->
let
class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptyInstEnv
in
returnNF_Tc class_lookup_fn
\end{code}
buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
\begin{code}
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
-> NF_TcM s (Class, InstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
= foldrNF_Tc addClassInstance
emptyInstEnv
inst_infos `thenNF_Tc` \ class_inst_env ->
returnNF_Tc (clas, class_inst_env)
buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
......@@ -118,16 +93,16 @@ addClassInstance
addClassInstance
(InstInfo clas inst_tyvars inst_tys _
dfun_id _ src_loc _)
class_inst_env
inst_env
= -- Add the instance to the class's instance environment
case addToInstEnv opt_AllowOverlappingInstances
class_inst_env inst_tyvars inst_tys dfun_id of
inst_env clas inst_tyvars inst_tys dfun_id of
Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
(tys', dfun_id'))
`thenNF_Tc_`
returnNF_Tc class_inst_env
returnNF_Tc inst_env
Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
Succeeded inst_env' -> returnNF_Tc inst_env'
\end{code}
\begin{code}
......
......@@ -27,7 +27,7 @@ import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, tcSetValueEnv,
explicitLookupValueByKey, tcSetValueEnv, tcSetInstEnv,
initEnv,
ValueEnv, TcTyThing(..)
)
......@@ -36,7 +36,7 @@ import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
import TcInstUtil ( buildInstanceEnv, InstInfo )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
......@@ -154,26 +154,19 @@ tcModule rn_name_supply fixities
-- unf_env is also used to get the pragam info
-- for imported dfuns and default methods
-- The knot for instance information. This isn't used at all
-- till we type-check value declarations
fixTc ( \ ~(rec_inst_mapper, _, _, _) ->
-- Type-check the type and class decls
tcTyAndClassDecls unf_env rec_inst_mapper decls `thenTc` \ env ->
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
-- Typecheck the instance decls, includes deriving
tcSetEnv env (
tcInstDecls1 unf_env decls mod_name fixities rn_name_supply
) `thenTc` \ (inst_info, deriv_binds) ->
buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper ->
returnTc (inst_mapper, env, inst_info, deriv_binds)
-- End of inner fix loop
) `thenTc` \ (_, env, inst_info, deriv_binds) ->
tcSetEnv env $
tcInstDecls1 unf_env decls
mod_name fixities
rn_name_supply `thenTc` \ (inst_info, deriv_binds) ->
tcSetEnv env (
buildInstanceEnv inst_info `thenNF_Tc` \ inst_env ->
tcSetInstEnv inst_env $
let
tycons = getEnvTyCons env
classes = getEnvClasses env
......@@ -296,7 +289,6 @@ tcModule rn_name_supply fixities
tc_rules = rules',
tc_env = really_final_env
}))
)
-- End of outer fix loop
) `thenTc` \ (final_env, stuff) ->
......
......@@ -143,18 +143,19 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
lieToList, listToLIE
)
import TcEnv ( tcGetGlobalTyVars )
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv,
InstEnv, lookupInstEnv, InstLookupResult(..)
)
import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy )
import Id ( idType )
import Class ( Class, classBigSig, classInstEnv )
import Class ( Class, classBigSig )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
import Type ( Type, ThetaType, TauType, ClassContext,
mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
......@@ -840,12 +841,11 @@ a,b,c are type variables. This is required for the context of
instance declarations.
\begin{code}
tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
-> ClassContext -- Wanted
tcSimplifyThetas :: ClassContext -- Wanted
-> TcM s ClassContext -- Needed
tcSimplifyThetas inst_mapper wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
tcSimplifyThetas wanteds
= reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let
-- For multi-param Haskell, check that the returned dictionaries
-- don't have any of the form (C Int Bool) for which
......@@ -874,7 +874,7 @@ tcSimplifyCheckThetas :: ClassContext -- Given
-> TcM s ()
tcSimplifyCheckThetas givens wanteds
= reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
= reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
if null irreds then
returnTc ()
else
......@@ -888,40 +888,38 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: (Class -> InstEnv)
-> ClassContext -- Given
reduceSimple :: ClassContext -- Given
-> ClassContext -- Wanted
-> NF_TcM s ClassContext -- Irreducible
reduceSimple inst_mapper givens wanteds
= reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
reduceSimple givens wanteds
= reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
reduce_simple :: (Int,ClassContext) -- Stack
-> (Class -> InstEnv)
-> AvailsSimple
-> ClassContext
-> NF_TcM s AvailsSimple
reduce_simple (n,stack) inst_mapper avails wanteds
reduce_simple (n,stack) avails wanteds
= go avails wanteds
where
go avails [] = returnNF_Tc avails
go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' ->
go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
go avails' ws
reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
reduce_simple_help stack givens wanted@(clas,tys)
| wanted `elemFM` givens
= returnNF_Tc givens
| otherwise
= lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
= lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
case maybe_theta of
Nothing -> returnNF_Tc (addIrred givens wanted)
Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
addIrred givens ct@(clas,tys)
......@@ -1265,45 +1263,52 @@ addTopInstanceErr dict
where
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
-- The error message when we don't find a suitable instance
-- is complicated by the fact that sometimes this is because
-- there is no instance, and sometimes it's because there are
-- too many instances (overlap). See the comments in TcEnv.lhs
-- with the InstEnv stuff.
addNoInstanceErr str givens dict
= addInstErrTcM (instLoc dict) (tidy_env, doc)
where
doc = vcat [herald <+> quotes (pprInst tidy_dict),
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
ambig_doc,
ptext SLIT("Probable fix:"),
nest 4 fix1,
nest 4 fix2]
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| otherwise = empty
ambig_doc
| not ambig_overlap = empty
| otherwise
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
nest 4 (ptext SLIT("depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
ptext SLIT("to the") <+> str]
fix2 | isTyVarDict dict || ambig_overlap
= empty
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
(tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
= case lookupInstEnv (classInstEnv clas) tys of
NoMatch ambig -> ambig
other -> False
| otherwise = False
where
(clas,tys) = getDictClassTys dict
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
let
doc = vcat [herald <+> quotes (pprInst tidy_dict),
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
ambig_doc,
ptext SLIT("Probable fix:"),
nest 4 fix1,
nest 4 fix2]
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| otherwise = empty
ambig_doc
| not ambig_overlap = empty
| otherwise
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
nest 4 (ptext SLIT("depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
ptext SLIT("to the") <+> str]
fix2 | isTyVarDict dict || ambig_overlap
= empty
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
(tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
= case lookupInstEnv inst_env clas tys of
NoMatch ambig -> ambig
other -> False
| otherwise = False
where
(clas,tys) = getDictClassTys dict
in
addInstErrTcM (instLoc dict) (tidy_env, doc)
-- Used for the ...Thetas variants; all top level
addNoInstErr (c,ts)
......
......@@ -20,7 +20,6 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
import BasicTypes ( RecFlag(..), NewOrData(..), Arity )
import TcMonad