Commit 3c58c25b authored by simonpj's avatar simonpj

[project @ 2002-11-28 17:17:41 by simonpj]

-------------------------------
      A day's work to improve error messages
	-------------------------------

1.  Indicate when the cause of the error is likely to be the monomorpism
    restriction, and identify the offending variables.  This involves
    mainly tcSimplifyTop and its error generation.

2.  Produce much better kind error messages.  No more
      ../alonzo/DiGraph.hs:40:
	  Couldn't match `* -> *' against `Type bx'
	      Expected kind: * -> *
	      Inferred kind: Type bx
	  When checking that `DiGraph n' is a type

It took a surprisingly long time to get the details right.
parent b44c6881
......@@ -31,7 +31,7 @@ module Inst (
zonkInst, zonkInsts,
instToId, instName,
InstOrigin(..), InstLoc, pprInstLoc
InstOrigin(..), InstLoc(..), pprInstLoc
) where
#include "HsVersions.h"
......@@ -224,11 +224,13 @@ newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
newDictsAtLoc :: InstLoc
-> TcThetaType
-> TcM [Inst]
newDictsAtLoc inst_loc@(_,loc,_) theta
newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us ->
returnM (zipWith mk_dict (uniqsFromSupply us) theta)
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
pred inst_loc
loc = instLocSrcLoc inst_loc
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
......@@ -237,7 +239,7 @@ newDictsAtLoc inst_loc@(_,loc,_) theta
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
= getInstLoc orig `thenM` \ inst_loc@(_,loc,_) ->
= getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) ->
newUnique `thenM` \ uniq ->
let
pred = IParam ip_name ty
......@@ -341,11 +343,12 @@ tcInstClassOp inst_loc sel_id tys
newMethod inst_loc sel_id tys [pred] tau
---------------------------
newMethod inst_loc@(_,loc,_) id tys theta tau
newMethod inst_loc id tys theta tau
= newUnique `thenM` \ new_uniq ->
let
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method meth_id id tys theta tau inst_loc
loc = instLocSrcLoc inst_loc
in
returnM inst
\end{code}
......
......@@ -4,8 +4,7 @@
\section[TcBinds]{TcBinds}
\begin{code}
module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
tcSpecSigs, tcBindWithSigs ) where
module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h"
......@@ -150,12 +149,7 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
-- c) the scope of the binding group (the "in" part)
tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
-- TYPECHECK THE SIGNATURES
mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenM` \ tc_ty_sigs ->
tcBindWithSigs top_lvl bind
tc_ty_sigs sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
getLIE (
-- Extend the environment to bind the new polymorphic Ids
......@@ -225,13 +219,18 @@ so all the clever stuff is in here.
tcBindWithSigs
:: TopLevelFlag
-> RenamedMonoBinds
-> [TcSigInfo]
-> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
-> RecFlag
-> TcM (TcMonoBinds, [TcId])
tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
= recoverM (
tcBindWithSigs top_lvl mbind sigs is_rec
= -- TYPECHECK THE SIGNATURES
recoverM (returnM []) (
mappM tcTySig [sig | sig@(Sig name _ _) <- sigs]
) `thenM` \ tc_ty_sigs ->
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
recoverM (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
......@@ -285,10 +284,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
poly_ids = [poly_id | (_, poly_id, _) <- exports]
dict_tys = map idType zonked_dict_ids
inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
inlines = mkNameSet [name | InlineSig True name _ loc <- sigs]
-- Any INLINE sig (regardless of phase control)
-- makes the RHS look small
inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs,
inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs,
not (isAlwaysActive phase)]
-- Set the IdInfo field to control the inline phase
-- AlwaysActive is the default, so don't bother with them
......
......@@ -23,6 +23,7 @@ module TcEnv(
tcLookup, tcLookupLocalIds, tcLookup_maybe,
tcLookupId, tcLookupIdLvl,
getLclEnvElts, getInLocalScope,
findGlobals,
-- Instance environment
tcExtendLocalInstEnv, tcExtendInstEnv,
......@@ -51,15 +52,18 @@ module TcEnv(
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import HsSyn ( RuleDecl(..), ifaceRuleDeclName )
import TcRnMonad
import TcMType ( zonkTcTyVarsAndFV )
import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
getDFunTyKey, tcTyConAppTyCon,
tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
tidyOpenType, tidyOpenTyVar
)
import qualified Type ( getTyVar_maybe )
import Rules ( extendRuleBase )
import Id ( idName, isDataConWrapId_maybe )
import Var ( TyVar, Id, idType )
import VarSet
import VarEnv
import CoreSyn ( IdCoreRule )
import DataCon ( DataCon )
import TyCon ( TyCon, DataConDetails )
......@@ -427,6 +431,62 @@ tcExtendLocalValEnv2 names_w_ids thing_inside
\end{code}
\begin{code}
-----------------------
-- findGlobals looks at the value environment and finds values
-- whose types mention the offending type variable. It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.
findGlobals :: TcTyVarSet
-> TidyEnv
-> TcM (TidyEnv, [SDoc])
findGlobals tvs tidy_env
= getLclEnvElts `thenM` \ lcl_env ->
go tidy_env [] lcl_env
where
go tidy_env acc [] = returnM (tidy_env, acc)
go tidy_env acc (thing : things)
= find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
case maybe_doc of
Just d -> go tidy_env1 (d:acc) things
Nothing -> go tidy_env1 acc things
ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
-----------------------
find_thing ignore_it tidy_env (ATcId id _)
= zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
returnM (tidy_env, Nothing)
else let
(tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
nest 2 (parens (ptext SLIT("bound at") <+>
ppr (getSrcLoc id)))]
in
returnM (tidy_env', Just msg)
find_thing ignore_it tidy_env (ATyVar tv)
= zonkTcTyVar tv `thenM` \ tv_ty ->
if ignore_it tv_ty then
returnM (tidy_env, Nothing)
else let
(tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
(tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
| otherwise = equals <+> ppr tv_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
bound_at = tyVarBindingInfo tv
in
returnM (tidy_env2, Just msg)
\end{code}
%************************************************************************
%* *
\subsection{The global tyvars}
......
......@@ -14,7 +14,7 @@ module TcMType (
newTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars, newBoxityVar,
newKindVar, newKindVars, newOpenTypeKind,
putTcTyVar, getTcTyVar,
newMutTyVar, readMutTyVar, writeMutTyVar,
......@@ -46,14 +46,14 @@ module TcMType (
-- friends:
import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation
Kind, ThetaType
Kind, ThetaType, typeCon
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
tcEqType, tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp,
isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy,
mkAppTy, mkTyVarTy, mkTyVarTys,
......@@ -131,11 +131,11 @@ newKindVar
newKindVars :: Int -> TcM [TcKind]
newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
newBoxityVar :: TcM TcKind
newBoxityVar
newOpenTypeKind :: TcM TcKind -- Returns the kind (Type bx), where bx is fresh
newOpenTypeKind
= newUnique `thenM` \ uniq ->
newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv ->
returnM (TyVarTy kv)
returnM (mkTyConApp typeCon [TyVarTy kv])
\end{code}
......
......@@ -28,18 +28,19 @@ import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
TyThing(..), TcTyThing(..), tcExtendKindEnv,
getInLocalScope
)
import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType, zonkTcType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt, newOpenTypeKind
)
import TcUnify ( unifyKind, unifyOpenTypeKind )
import TcUnify ( unifyKind, unifyOpenTypeKind, unifyFunKind )
import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
TcTyVar, TcKind, TcThetaType, TcTauType,
mkTyVarTy, mkTyVarTys, mkFunTy,
mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind,
zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, mkArrowKind,
liftedTypeKind, unliftedTypeKind, mkArrowKind, eqKind,
mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
)
import qualified Type ( splitFunTys )
import Inst ( Inst, InstOrigin(..), newMethod, instToId )
import Id ( mkLocalId, idName, idType )
......@@ -237,44 +238,44 @@ newNamedKindVar name = newKindVar `thenM` \ kind ->
returnM (name, kind)
---------------------------
kcLiftedType :: RenamedHsType -> TcM ()
kcLiftedType :: RenamedHsType -> TcM Kind
-- The type ty must be a *lifted* *type*
kcLiftedType ty
= kcHsType ty `thenM` \ kind ->
addErrCtxt (typeKindCtxt ty) $
unifyKind liftedTypeKind kind
kcLiftedType ty = kcHsType ty `thenM` \ act_kind ->
checkExpectedKind (ppr ty) act_kind liftedTypeKind
---------------------------
kcTypeType :: RenamedHsType -> TcM ()
-- The type ty must be a *type*, but it can be lifted or unlifted.
kcTypeType ty
= kcHsType ty `thenM` \ kind ->
addErrCtxt (typeKindCtxt ty) $
unifyOpenTypeKind kind
= kcHsType ty `thenM` \ kind ->
if isTypeKind kind then
return ()
else
newOpenTypeKind `thenM` \ exp_kind ->
checkExpectedKind (ppr ty) kind exp_kind `thenM_`
returnM ()
---------------------------
kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM ()
-- Used for type signatures
kcHsSigType = kcTypeType
kcHsSigTypes tys = mappM_ kcHsSigType tys
kcHsLiftedSigType = kcLiftedType
kcHsSigType ty = kcTypeType ty
kcHsSigTypes tys = mappM_ kcHsSigType tys
kcHsLiftedSigType ty = kcLiftedType ty `thenM_` returnM ()
---------------------------
kcHsType :: RenamedHsType -> TcM TcKind
kcHsType (HsTyVar name) = kcTyVar name
kcHsType (HsKindSig ty k)
= kcHsType ty `thenM` \ k' ->
unifyKind k k' `thenM_`
returnM k
kcHsType (HsListTy ty)
= kcLiftedType ty `thenM` \ tau_ty ->
returnM liftedTypeKind
kcHsType (HsPArrTy ty)
= kcLiftedType ty `thenM` \ tau_ty ->
returnM liftedTypeKind
-- kcHsType *returns* the kind of the type, rather than taking an expected
-- kind as argument as tcExpr does. Reason: the kind of (->) is
-- forall bx1 bx2. Type bx1 -> Type bx2 -> Type Boxed
-- so we'd need to generate huge numbers of bx variables.
kcHsType (HsTyVar name) = kcTyVar name
kcHsType (HsListTy ty) = kcLiftedType ty
kcHsType (HsPArrTy ty) = kcLiftedType ty
kcHsType (HsParTy ty) = kcHsType ty -- Skip parentheses markers
kcHsType (HsNumTy _) = returnM liftedTypeKind -- The unit type for generics
kcHsType (HsKindSig ty k) = kcHsType ty `thenM` \ act_kind ->
checkExpectedKind (ppr ty) act_kind k
kcHsType (HsTupleTy (HsTupCon boxity _) tys)
= mappM kcTypeType tys `thenM_`
......@@ -292,51 +293,104 @@ kcHsType (HsOpTy ty1 HsArrow ty2)
kcTypeType ty2 `thenM_`
returnM liftedTypeKind
kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
= kcTyVar op `thenM` \ op_kind ->
kcHsType ty1 `thenM` \ ty1_kind ->
kcHsType ty2 `thenM` \ ty2_kind ->
addErrCtxt (appKindCtxt (ppr ty)) $
kcAppKind op_kind ty1_kind `thenM` \ op_kind' ->
kcAppKind op_kind' ty2_kind
kcHsType (HsParTy ty) -- Skip parentheses markers
= kcHsType ty
kcHsType (HsNumTy _) -- The unit type for generics
= returnM liftedTypeKind
kcHsType ty@(HsOpTy ty1 op_ty@(HsTyOp op) ty2)
= addErrCtxt (appKindCtxt (ppr ty)) $
kcTyVar op `thenM` \ op_kind ->
kcApps (ppr op_ty) op_kind [ty1,ty2]
kcHsType (HsPredTy pred)
= kcHsPred pred `thenM_`
returnM liftedTypeKind
kcHsType ty@(HsAppTy ty1 ty2)
= kcHsType ty1 `thenM` \ tc_kind ->
kcHsType ty2 `thenM` \ arg_kind ->
addErrCtxt (appKindCtxt (ppr ty)) $
kcAppKind tc_kind arg_kind
= addErrCtxt (appKindCtxt (ppr ty)) $
kc_app ty []
where
kc_app (HsAppTy f a) as = kc_app f (a:as)
kc_app f as = kcHsType f `thenM` \ fk ->
kcApps (ppr f) fk as
kcHsType (HsForAllTy (Just tv_names) context ty)
= kcHsTyVars tv_names `thenM` \ kind_env ->
tcExtendKindEnv kind_env $
kcHsContext context `thenM_`
kcLiftedType ty `thenM_`
kcLiftedType ty
-- The body of a forall must be of kind *
-- In principle, I suppose, we could allow unlifted types,
-- but it seems simpler to stick to lifted types for now.
returnM liftedTypeKind
---------------------------
kcAppKind fun_kind arg_kind
= case tcSplitFunTy_maybe fun_kind of
Just (arg_kind', res_kind)
-> unifyKind arg_kind arg_kind' `thenM_`
returnM res_kind
kcApps :: SDoc -- The function
-> TcKind -- Function kind
-> [RenamedHsType] -- Arg types
-> TcM TcKind -- Result kind
kcApps pp_fun fun_kind args
= go fun_kind args
where
go fk [] = returnM fk
go fk (ty:tys) = unifyFunKind fk `thenM` \ mb_fk ->
case mb_fk of {
Nothing -> failWithTc too_few_args ;
Just (ak',fk') ->
kcHsType ty `thenM` \ ak ->
checkExpectedKind (ppr ty) ak ak' `thenM_`
go fk' tys }
too_few_args = ptext SLIT("Kind error:") <+> quotes pp_fun <+>
ptext SLIT("is applied to too many type arguments")
Nothing -> newKindVar `thenM` \ res_kind ->
unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenM_`
returnM res_kind
---------------------------
-- We would like to get a decent error message from
-- (a) Under-applied type constructors
-- f :: (Maybe, Maybe)
-- (b) Over-applied type constructors
-- f :: Int x -> Int x
--
checkExpectedKind :: SDoc -> TcKind -> TcKind -> TcM TcKind
-- A fancy wrapper for 'unifyKind', which tries to give
-- decent error messages.
-- Returns the same kind that it is passed, exp_kind
checkExpectedKind pp_ty act_kind exp_kind
| act_kind `eqKind` exp_kind -- Short cut for a very common case
= returnM exp_kind
| otherwise
= tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) ->
case mb_r of {
Just _ -> returnM exp_kind ; -- Unification succeeded
Nothing ->
-- So there's definitely an error
-- Now to find out what sort
zonkTcType exp_kind `thenM` \ exp_kind ->
zonkTcType act_kind `thenM` \ act_kind ->
let (exp_as, _) = Type.splitFunTys exp_kind
(act_as, _) = Type.splitFunTys act_kind
-- Use the Type versions for kinds
n_exp_as = length exp_as
n_act_as = length act_as
err | n_exp_as < n_act_as -- E.g. [Maybe]
= quotes pp_ty <+> ptext SLIT("is not applied to enough type arguments")
-- Now n_exp_as >= n_act_as. In the next two cases,
-- n_exp_as == 0, and hence so is n_act_as
| exp_kind `eqKind` liftedTypeKind && act_kind `eqKind` unliftedTypeKind
= ptext SLIT("Expecting a lifted type, but") <+> quotes pp_ty
<+> ptext SLIT("is unlifted")
| exp_kind `eqKind` unliftedTypeKind && act_kind `eqKind` liftedTypeKind
= ptext SLIT("Expecting an unlifted type, but") <+> quotes pp_ty
<+> ptext SLIT("is lifted")
| otherwise -- E.g. Monad [Int]
= sep [ ptext SLIT("Expecting kind") <+> quotes (ppr exp_kind) <> comma,
ptext SLIT("but") <+> quotes pp_ty <+>
ptext SLIT("has kind") <+> quotes (ppr act_kind)]
in
failWithTc (ptext SLIT("Kind error:") <+> err)
}
---------------------------
kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated
......@@ -345,20 +399,16 @@ kc_pred pred@(HsIParam name ty)
= kcHsType ty
kc_pred pred@(HsClassP cls tys)
= kcClass cls `thenM` \ kind ->
mappM kcHsType tys `thenM` \ arg_kinds ->
newKindVar `thenM` \ kv ->
unifyKind kind (mkArrowKinds arg_kinds kv) `thenM_`
returnM kv
= kcClass cls `thenM` \ kind ->
kcApps (ppr cls) kind tys
---------------------------
kcHsContext ctxt = mappM_ kcHsPred ctxt
kcHsPred pred -- Checks that the result is of kind liftedType
= addErrCtxt (appKindCtxt (ppr pred)) $
kc_pred pred `thenM` \ kind ->
unifyKind liftedTypeKind kind `thenM_`
returnM ()
kc_pred pred `thenM` \ kind ->
checkExpectedKind (ppr pred) kind liftedTypeKind
---------------------------
......@@ -454,7 +504,9 @@ tc_type (HsNumTy n)
= ASSERT(n== 1)
returnM (mkTyConApp genUnitTyCon [])
tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
tc_type ty@(HsAppTy ty1 ty2)
= addErrCtxt (appKindCtxt (ppr ty)) $
tc_app ty1 [ty2]
tc_type (HsPredTy pred)
= tc_pred pred `thenM` \ pred' ->
......@@ -481,14 +533,11 @@ tc_app (HsAppTy ty1 ty2) tys
= tc_app ty1 (ty2:tys)
tc_app ty tys
= addErrCtxt (appKindCtxt pp_app) $
tc_types tys `thenM` \ arg_tys ->
= tc_types tys `thenM` \ arg_tys ->
case ty of
HsTyVar fun -> tc_fun_type fun arg_tys
other -> tc_type ty `thenM` \ fun_ty ->
returnM (mkAppTys fun_ty arg_tys)
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
-- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
......
......@@ -702,7 +702,7 @@ tcTopSrcDecls rn_decls
-- in this module, which is why the knot is so big
-- Do the main work
((tcg_env, binds, rules, fords), lie) <- getLIE (
((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
tc_src_decls unf_env rn_decls
) ;
......@@ -713,8 +713,12 @@ tcTopSrcDecls rn_decls
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
traceTc (text "Tc8") ;
inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
inst_binds <- setGblEnv tcg_env $
setLclTypeEnv lcl_env $
tcSimplifyTop lie ;
-- The setGblEnv exposes the instances to tcSimplifyTop
-- The steLclTypeEnv exposes the local Ids, so that
-- we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
......@@ -799,7 +803,7 @@ tc_src_decls unf_env
cls_dm_binds `AndMonoBinds`
foe_binds } ;
return (tcg_env, all_binds, src_rules, foe_decls)
return (tcg_env, lcl_env, all_binds, src_rules, foe_decls)
}}}}}}}}}
\end{code}
......
......@@ -582,7 +582,13 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
= do { loc <- getSrcLocM ; env <- getLclEnv ;
return (origin, loc, (tcl_ctxt env)) }
return (InstLoc origin loc (tcl_ctxt env)) }
addInstCtxt :: InstLoc -> TcM a -> TcM a
-- Add the SrcLoc and context from the first Inst in the list
-- (they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
= addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
\end{code}
The addErrTc functions add an error message, but do not cause failure.
......@@ -601,12 +607,6 @@ addErrTcM (tidy_env, err_msg)
= do { ctxt <- getErrCtxt ;
loc <- getSrcLocM ;
add_err_tcm tidy_env err_msg loc ctxt }
addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM ()
addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg)
= add_err_tcm tidy_env err_msg loc full_ctxt
where
full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt
\end{code}
The failWith functions add an error message and cause failure
......
......@@ -34,7 +34,7 @@ module TcRnTypes(
Level, impLevel, topLevel,
-- Insts
Inst(..), InstOrigin(..), InstLoc, pprInstLoc,
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,
LIE, emptyLIE, unitLIE, plusLIE, consLIE,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
......@@ -374,6 +374,12 @@ data TcTyThing
-- 2. Then we kind-check the (T a Int) part.
-- 3. Then we zonk the kind variable.
-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
instance Outputable TcTyThing where -- Debugging only
ppr (AGlobal g) = text "AGlobal" <+> ppr g
ppr (ATcId g l) = text "ATcId" <+> ppr g <+> ppr l
ppr (ATyVar t) = text "ATyVar" <+> ppr t
ppr (AThing k) = text "AThing" <+> ppr k
\end{code}
\begin{code}
......@@ -739,7 +745,10 @@ It appears in TcMonad because there are a couple of error-message-generation
functions that deal with it.
\begin{code}
type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
data InstLoc = InstLoc InstOrigin SrcLoc ErrCtxt
instLocSrcLoc :: InstLoc -> SrcLoc
instLocSrcLoc (InstLoc _ src_loc _) = src_loc
data InstOrigin
= OccurrenceOf Name -- Occurrence of an overloaded identifier
......@@ -794,7 +803,7 @@ data InstOrigin
\begin{code}
pprInstLoc :: InstLoc -> SDoc
pprInstLoc (orig, locn, ctxt)
pprInstLoc (InstLoc orig locn ctxt)
= hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
pp_orig (OccurrenceOf name)
......
......@@ -19,7 +19,7 @@ module TcSimplify (
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyTauTy )
import TcEnv -- temp
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
......@@ -39,7 +39,7 @@ import Inst ( lookupInst, LookupInstResult(..),
Inst, pprInsts, pprInstsInFull,
isIPDict, isInheritableInst
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId )
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
......@@ -57,7 +57,9 @@ import PrelNames ( splitName, fstName, sndName )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy, pairTyCon )
import ErrUtils ( Message )
import VarSet
import VarEnv ( TidyEnv )
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
......@@ -1607,7 +1609,9 @@ It's OK: the final zonking stage should zap y to (), which is fine.
\begin{code}
tcSimplifyTop :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
= simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
= getLclEnvElts `thenM` \ lcl_env ->
traceTc (text "tcSimplifyTop" <+> ppr lcl_env) `thenM_`
simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
ASSERT( null frees )
let
......@@ -1634,8 +1638,8 @@ tcSimplifyTop wanteds
in
-- Report definite errors
mappM (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenM_`
mappM (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenM_`
addTopInstanceErrs tidy_env no_insts `thenM_`
addTopIPErrs tidy_env bad_ips `thenM_`
-- Deal with ambiguity errors, but only if
-- if there has not been an error so far; errors often
......@@ -1648,7 +1652,7 @@ tcSimplifyTop wanteds
-- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries
-- e.g. Num a
mappM (addAmbigErr tidy_env) ambigs `thenM_`
addTopAmbigErrs (tidy_env, ambigs) `thenM_`