zonkInst, zonkInsts,
instToId, instName,
- InstOrigin(..), InstLoc, pprInstLoc
+ InstOrigin(..), InstLoc(..), pprInstLoc
) where
#include "HsVersions.h"
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
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
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}
\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
- tcSpecSigs, tcBindWithSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h"
-- 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
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
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
tcLookup, tcLookupLocalIds, tcLookup_maybe,
tcLookupId, tcLookupIdLvl,
getLclEnvElts, getInLocalScope,
+ findGlobals,
-- Instance environment
tcExtendLocalInstEnv, tcExtendInstEnv,
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 )
\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}
newTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
- newKindVar, newKindVars, newBoxityVar,
+ newKindVar, newKindVars, newOpenTypeKind,
putTcTyVar, getTcTyVar,
newMutTyVar, readMutTyVar, writeMutTyVar,
-- 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,
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}
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 )
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_`
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
= 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
---------------------------
= 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' ->
= 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
-- 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
) ;
-- 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.
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}
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.
= 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
Level, impLevel, topLevel,
-- Insts
- Inst(..), InstOrigin(..), InstLoc, pprInstLoc,
+ Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,
LIE, emptyLIE, unitLIE, plusLIE, consLIE,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
-- 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}
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
\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)
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyTauTy )
-
+import TcEnv -- temp
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
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),
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy, pairTyCon )
+import ErrUtils ( Message )
import VarSet
+import VarEnv ( TidyEnv )
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
\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
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
-- 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_`
-- Disambiguate the ones that look feasible
mappM disambigGroup std_oks
tryM (try_default default_tys) `thenM` \ mb_ty ->
case mb_ty of {
Left _ -> -- If not, add an AmbigErr
- addAmbigErrs dicts `thenM_`
+ addTopAmbigErrs (tidyInsts dicts) `thenM_`
returnM EmptyMonoBinds ;
Right chosen_default_ty ->
| all isCreturnableClass classes
= -- Default CCall stuff to (); we don't even both to check that () is an
-- instance of CReturnable, because we know it is.
- unifyTauTy (mkTyVarTy tyvar) unitTy `thenM_`
+ unifyTauTy (mkTyVarTy tyvar) unitTy `thenM_`
returnM EmptyMonoBinds
| otherwise -- No defaults
- = addAmbigErrs dicts `thenM_`
+ = addTopAmbigErrs (tidyInsts dicts) `thenM_`
returnM EmptyMonoBinds
where
now?
\begin{code}
-groupInsts :: [Inst] -> [[Inst]]
+groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
+ -> [Inst] -- The offending Insts
+ -> TcM ()
-- Group together insts with the same origin
-- We want to report them together in error messages
-groupInsts [] = []
-groupInsts (inst:insts) = (inst:friends) : groupInsts others
- where
- -- (It may seem a bit crude to compare the error messages,
- -- but it makes sure that we combine just what the user sees,
- -- and it avoids need equality on InstLocs.)
- (friends, others) = partition is_friend insts
- loc_msg = showSDoc (pprInstLoc (instLoc inst))
- is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
+
+groupErrs report_err []
+ = returnM ()
+groupErrs report_err (inst:insts)
+ = do_one (inst:friends) `thenM_`
+ groupErrs report_err others
+
+ where
+ -- (It may seem a bit crude to compare the error messages,
+ -- but it makes sure that we combine just what the user sees,
+ -- and it avoids need equality on InstLocs.)
+ (friends, others) = partition is_friend insts
+ loc_msg = showSDoc (pprInstLoc (instLoc inst))
+ is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
+ do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
+ -- Add location and context information derived from the Insts
+
+-- Add the "arising from..." part to a message about bunch of dicts
+addInstLoc :: [Inst] -> Message -> Message
+addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts)))
plural [x] = empty
plural xs = char 's'
+
addTopIPErrs tidy_env tidy_dicts
- = addInstErrTcM (instLoc (head tidy_dicts))
- (tidy_env,
- ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts)
+ = groupErrs report tidy_dicts
+ where
+ report dicts = addErrTcM (tidy_env, mk_msg dicts)
+ mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
+ plural tidy_dicts <+> pprInsts tidy_dicts)
-- Used for top-level irreducibles
addTopInstanceErrs tidy_env tidy_dicts
- = addInstErrTcM (instLoc (head tidy_dicts))
- (tidy_env,
- ptext SLIT("No instance") <> plural tidy_dicts <+>
- ptext SLIT("for") <+> pprInsts tidy_dicts)
-
-addAmbigErrs dicts
- = mappM (addAmbigErr tidy_env) tidy_dicts
+ = groupErrs report tidy_dicts
where
- (tidy_env, tidy_dicts) = tidyInsts dicts
-
-addAmbigErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
- (tidy_env,
- sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
- nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
+ report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
+ addErrTcM (tidy_env, mk_msg dicts $$ mono_msg)
+ mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+>
+ ptext SLIT("for") <+> pprInsts tidy_dicts)
+
+
+addTopAmbigErrs (tidy_env, tidy_dicts)
+ = groupErrs report tidy_dicts
where
- ambig_tvs = varSetElems (tyVarsOfInst tidy_dict)
+ report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
+ addErrTcM (tidy_env, mk_msg dicts $$ mono_msg)
+ mk_msg dicts = addInstLoc dicts $
+ sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
+ nest 2 (text "in the constraint" <> plural dicts <+> pprInsts dicts)]
+ where
+ ambig_tvs = varSetElems (tyVarsOfInsts dicts)
+
+mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)
+-- There's an error with these Insts; if they have free type variables
+-- it's probably caused by the monomorphism restriction.
+-- Try to identify the offending variable
+-- ASSUMPTION: the Insts are fully zonked
+mkMonomorphismMsg tidy_env insts
+ | isEmptyVarSet inst_tvs
+ = returnM (tidy_env, empty)
+ | otherwise
+ = findGlobals inst_tvs tidy_env `thenM` \ (tidy_env, docs) ->
+ returnM (tidy_env, mk_msg docs)
+ where
+ inst_tvs = tyVarsOfInsts insts
+
+ mk_msg [] = empty -- This happens in things like
+ -- f x = show (read "foo")
+ -- whre monomorphism doesn't play any role
+ mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
+ nest 2 (vcat docs)]
+
warnDefault dicts default_ty
= doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
- addSrcLoc (get_loc (head dicts)) (warnTc warn_flag warn_msg)
+ addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
where
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
- get_loc i = case instLoc i of { (_,loc,_) -> loc }
warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
quotes (ppr default_ty),
pprInstsInFull tidy_dicts]
complainCheck doc givens irreds
- = mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
- mappM (addNoInstanceErrs doc givens') (groupInsts irreds) `thenM_`
+ = mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
+ groupErrs (addNoInstanceErrs doc givens') irreds `thenM_`
returnM ()
where
given_dicts_and_ips = filter (not . isMethod) givens
(tidy_env1, tidy_givens) = tidyInsts givens
(tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
- doc = vcat [sep [herald <+> pprInsts tidy_dicts,
+ doc = vcat [addInstLoc dicts $
+ sep [herald <+> pprInsts tidy_dicts,
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
ambig_doc,
ptext SLIT("Probable fix:"),
where
(clas,tys) = getDictClassTys dict
in
- addInstErrTcM (instLoc (head dicts)) (tidy_env2, doc)
+ addErrTcM (tidy_env2, doc)
-- Used for the ...Thetas variants; all top level
noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
module TcUnify (
-- Full-blown subsumption
tcSubOff, tcSubExp, tcGen, subFunTy, TcHoleType,
- checkSigTyVars, checkSigTyVarsWrt, sigCtxt,
+ checkSigTyVars, checkSigTyVarsWrt, sigCtxt, findGlobals,
-- Various unifications
unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy,
- unifyKind, unifyKinds, unifyOpenTypeKind,
+ unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind,
-- Coercions
Coercion, ExprCoFn, PatCoFn,
import HsSyn ( HsExpr(..) )
import TcHsSyn ( TypecheckedHsExpr, TcPat, mkHsLet )
-import TypeRep ( Type(..), SourceType(..), TyNote(..),
- openKindCon, typeCon )
+import TypeRep ( Type(..), SourceType(..), TyNote(..), openKindCon )
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
typeKind, tcSplitFunTy_maybe, mkForAllTys,
isHoleTyVar, isSkolemTyVar, isUserTyVar,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
- eqKind, openTypeKind, liftedTypeKind, isTypeKind,
- hasMoreBoxityInfo, tyVarBindingInfo, allDistinctTyVars
+ eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind,
+ hasMoreBoxityInfo, allDistinctTyVars
)
import qualified Type ( getTyVar_maybe )
import Inst ( newDicts, instToId, tcInstCall )
-import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult,
- newTyVarTy, newTyVarTys, newBoxityVar, newHoleTyVarTy,
+import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult, newKindVar,
+ newTyVarTy, newTyVarTys, newOpenTypeKind, newHoleTyVarTy,
zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar )
import TcSimplify ( tcSimplifyCheck )
import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy )
-import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, getLclEnvElts )
+import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, findGlobals )
import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity )
import PprType ( pprType )
import Id ( Id, mkSysLocal, idType )
import Var ( Var, varName, tyVarKind )
-import VarSet ( emptyVarSet, unionVarSet, elemVarSet, varSetElems )
+import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
import VarEnv
import Name ( isSystemName, getSrcLoc )
import ErrUtils ( Message )
unifyKind :: TcKind -- Expected
-> TcKind -- Actual
-> TcM ()
-unifyKind k1 k2
- = addErrCtxtM (unifyCtxt "kind" k1 k2) $
- uTys k1 k1 k2 k2
+unifyKind k1 k2 = uTys k1 k1 k2 k2
unifyKinds :: [TcKind] -> [TcKind] -> TcM ()
unifyKinds [] [] = returnM ()
| otherwise = unify_open_kind_help ty
unify_open_kind_help ty -- Revert to ordinary unification
- = newBoxityVar `thenM` \ boxity ->
- unifyKind ty (mkTyConApp typeCon [boxity])
+ = newOpenTypeKind `thenM` \ open_kind ->
+ unifyKind ty open_kind
\end{code}
+\begin{code}
+unifyFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind))
+-- Like unifyFunTy, but does not fail; instead just returns Nothing
+
+unifyFunKind (TyVarTy tyvar)
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
+ case maybe_ty of
+ Just fun_kind -> unifyFunKind fun_kind
+ Nothing -> newKindVar `thenM` \ arg_kind ->
+ newKindVar `thenM` \ res_kind ->
+ putTcTyVar tyvar (mkArrowKind arg_kind res_kind) `thenM_`
+ returnM (Just (arg_kind,res_kind))
+
+unifyFunKind (FunTy arg_kind res_kind) = returnM (Just (arg_kind,res_kind))
+unifyFunKind (NoteTy _ ty) = unifyFunKind ty
+unifyFunKind other = returnM Nothing
+\end{code}
%************************************************************************
%* *
-- Game plan:
-- get the local TcIds and TyVars from the environment,
-- and pass them to find_globals (they might have tv free)
- then getLclEnvElts `thenM` \ ve ->
- find_globals tv tidy_env ve `thenM` \ (tidy_env1, globs) ->
+ then findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) ->
returnM (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK
\begin{code}
-----------------------
--- find_globals 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.
-
-find_globals :: Var
- -> TidyEnv
- -> [TcTyThing]
- -> TcM (TidyEnv, [SDoc])
-
-find_globals tv tidy_env things
- = go tidy_env [] things
- 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 (tv `elemVarSet` 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)
-
------------------------
escape_msg sig_tv tv globs
= mk_msg sig_tv <+> ptext SLIT("escapes") $$
if notNull globs then
projects / ghc-hetmet.git / commitdiff