#include "HsVersions.h"
-import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
+import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn ( TcHsBinds, TcMonoBinds,
- TcIdOcc(..), TcIdBndr,
- tcIdType, zonkId
- )
+import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId )
import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
)
-import TcEnv ( tcExtendLocalValEnv, tcExtendEnvWithPat,
- tcLookupLocalValueOK,
+import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId,
+ tcLookupTyCon,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
-import TcMatches ( tcMatchesFun )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
-import TcMonoType ( tcHsTcType, checkSigTyVars,
+import TcMonoType ( tcHsType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcVarPat, tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcType, TcThetaType,
TcTyVar,
- newTyVarTy, newTcTyVar, tcInstTcType,
- zonkTcType, zonkTcTypes, zonkTcThetaType )
+ newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
+ zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+ )
import TcUnify ( unifyTauTy, unifyTauTyLists )
+import PrelInfo ( main_NAME, ioTyCon_NAME )
+
import Id ( mkUserId )
import Var ( idType, idName, setIdInfo )
import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Name ( Name )
-import Type ( mkTyVarTy, tyVarsOfTypes,
+import Name ( Name, getName )
+import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
- isUnboxedType, openTypeKind,
- unboxedTypeKind, boxedTypeKind
+ isUnboxedType, unboxedTypeKind, boxedTypeKind
)
import Var ( TyVar, tyVarKind )
import VarSet
import Bag
import Util ( isIn )
+import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import SrcLoc ( SrcLoc )
import Outputable
\begin{code}
tcTopBindsAndThen, tcBindsAndThen
- :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
+ :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
- -> TcM s (thing, LIE s)
- -> TcM s (thing, LIE s)
+ -> TcM s (thing, LIE)
+ -> TcM s (thing, LIE)
tcTopBindsAndThen = tc_binds_and_then TopLevel
tcBindsAndThen = tc_binds_and_then NotTopLevel
tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
- tcExtendLocalValEnv (map idName poly_ids) poly_ids $
+ tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
-- Build bindings and IdInfos corresponding to user pragmas
tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
\begin{pseudocode}
% tcBindsAndThen
% :: RenamedHsBinds
-% -> TcM s (thing, LIE s, thing_ty))
-% -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
+% -> TcM s (thing, LIE, thing_ty))
+% -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
%
% tcBindsAndThen EmptyBinds do_next
% = do_next `thenTc` \ (thing, lie, thing_ty) ->
tcBindWithSigs
:: TopLevelFlag
-> RenamedMonoBinds
- -> [TcSigInfo s]
+ -> [TcSigInfo]
-> RecFlag
-> (Name -> IdInfo)
- -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
+ -> TcM s (TcMonoBinds, LIE, [TcId])
tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
= recoverTc (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
- newTcTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
binder_names = map fst (bagToList (collectMonoBinders mbind))
-- TYPECHECK THE BINDINGS
tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
- let
- mono_id_tys = map idType mono_ids
- in
-
-- CHECK THAT THE SIGNATURES MATCH
-- (must do this before getTyVarsToGen)
- checkSigMatch tc_ty_sigs `thenTc` \ (sig_theta, lie_avail) ->
+ checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
+ let
+ mono_id_tys = map idType mono_ids
+ in
getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
- -- DEAL WITH TYPE VARIABLE KINDS
- -- **** This step can do unification => keep other zonking after this ****
- mapTc defaultUncommittedTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ -- Finally, zonk the generalised type variables to real TyVars
+ -- This commits any unbound kind variables to boxed kind
+ -- I'm a little worried that such a kind variable might be
+ -- free in the environment, but I don't think it's possible for
+ -- this to happen when the type variable is not free in the envt
+ -- (which it isn't). SLPJ Nov 98
+ mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
-- It's important that the final list
-- No polymorphism, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
- if null tc_ty_sigs then
+ case maybe_sig_theta of
+ Nothing ->
-- No signatures, so just simplify the lie
-- NB: no signatures => no polymorphic recursion, so no
-- need to use lie_avail (which will be empty anyway)
top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
- else
+ Just (sig_theta, lie_avail) ->
+ -- There are signatures, and their context is sig_theta
+ -- Furthermore, lie_avail is an LIE containing the 'method insts'
+ -- for the things bound here
+
zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
-- It's important that sig_theta is zonked, because
mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
let
exports = zipWith mk_export binder_names zonked_mono_ids
- dict_tys = map tcIdType dicts_bound
+ dict_tys = map idType dicts_bound
mk_export binder_name zonked_mono_id
= (tyvars,
- TcId (setIdInfo poly_id (prag_info_fn binder_name)),
- TcId zonked_mono_id)
+ setIdInfo poly_id (prag_info_fn binder_name),
+ zonked_mono_id)
where
(tyvars, poly_id) =
case maybeSig tc_ty_sigs binder_name of
exports
(dict_binds `andMonoBinds` mbind'),
lie_free,
- [poly_id | (_, TcId poly_id, _) <- exports]
+ [poly_id | (_, poly_id, _) <- exports]
)
where
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
is_elem v vs = isIn "isUnResMono" v vs
isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
+isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs EmptyMonoBinds = True
\end{code}
-@defaultUncommittedTyVar@ checks for generalisation over unboxed
-types, and defaults any TypeKind TyVars to BoxedTypeKind.
-
-\begin{code}
-defaultUncommittedTyVar tyvar
- | tyVarKind tyvar == openTypeKind
- = newTcTyVar boxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
- unifyTauTy (mkTyVarTy tyvar) (mkTyVarTy boxed_tyvar) `thenTc_`
- returnTc boxed_tyvar
-
- | otherwise
- = returnTc tyvar
-\end{code}
-
%************************************************************************
%* *
\begin{code}
tcMonoBinds :: RenamedMonoBinds
- -> [TcSigInfo s]
+ -> [TcSigInfo]
-> RecFlag
- -> TcM s (TcMonoBinds s,
- LIE s, -- LIE required
+ -> TcM s (TcMonoBinds,
+ LIE, -- LIE required
[Name], -- Bound names
- [TcIdBndr s]) -- Corresponding monomorphic bound things
+ [TcId]) -- Corresponding monomorphic bound things
tcMonoBinds mbinds tc_ty_sigs is_rec
= tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
let
tv_list = bagToList tvs
- (names, mono_ids) = unzip (bagToList ids)
+ id_list = bagToList ids
+ (names, mono_ids) = unzip id_list
+
+ -- This last defn is the key one:
+ -- extend the val envt with bindings for the
+ -- things bound in this group, overriding the monomorphic
+ -- ids with the polymorphic ones from the pattern
+ extra_val_env = case is_rec of
+ Recursive -> map mk_bind id_list
+ NonRecursive -> []
in
-- Don't know how to deal with pattern-bound existentials yet
checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
(existentialExplode mbinds) `thenTc_`
- -- *Before* checking the RHSs, but *after* checking *all* the patterns,
+ -- *Before* checking the RHSs, but *after* checking *all* the patterns,
-- extend the envt with bindings for all the bound ids;
-- and *then* override with the polymorphic Ids from the signatures
-- That is the whole point of the "complete_it" stuff.
- tcExtendEnvWithPat ids (tcExtendEnvWithPat sig_ids
- complete_it
- ) `thenTc` \ (mbinds', lie_req_rhss) ->
+ --
+ -- There's a further wrinkle: we have to delay extending the environment
+ -- until after we've dealt with any pattern-bound signature type variables
+ -- Consider f (x::a) = ...f...
+ -- We're going to check that a isn't unified with anything in the envt,
+ -- so f itself had better not be! So we pass the envt binding f into
+ -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
+ -- dealing with the signature tyvars
+
+ complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
+
returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
where
sig_fn name = case maybeSig tc_ty_sigs name of
Nothing -> Nothing
Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
- sig_ids = listToBag [(name,poly_id) | TySigInfo name poly_id _ _ _ _ _ _ <- tc_ty_sigs]
-
- kind = case is_rec of
- Recursive -> boxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
+ mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
+ Nothing -> (name, mono_id)
+ Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
tc_mb_pats EmptyMonoBinds
- = returnTc (returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+ = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
tc_mb_pats (AndMonoBinds mb1 mb2)
= tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
let
- complete_it = complete_it1 `thenTc` \ (mb1', lie1) ->
- complete_it2 `thenTc` \ (mb2', lie2) ->
- returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
+ complete_it2 xve `thenTc` \ (mb2', lie2) ->
+ returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
in
returnTc (complete_it,
lie_req1 `plusLIE` lie_req2,
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
- tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+ = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
+ tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id ->
let
- complete_it = tcAddSrcLoc locn $
- tcMatchesFun name pat_ty matches `thenTc` \ (matches', lie) ->
- returnTc (FunMonoBind (TcId bndr_id) inf matches' locn, lie)
+ complete_it xve = tcAddSrcLoc locn $
+ tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
+ returnTc (FunMonoBind bndr_id inf matches' locn, lie)
in
returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
- tc_mb_pats bind@(PatMonoBind pat grhss_and_binds locn)
+ tc_mb_pats bind@(PatMonoBind pat grhss locn)
= tcAddSrcLoc locn $
- newTyVarTy kind `thenNF_Tc` \ pat_ty ->
+
+ -- Figure out the appropriate kind for the pattern,
+ -- and generate a suitable type variable
+ (case is_rec of
+ Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
+ ) `thenNF_Tc` \ pat_ty ->
+
+ -- Now typecheck the pattern
+ -- We don't support binding fresh type variables in the
+ -- pattern of a pattern binding. For example, this is illegal:
+ -- (x::a, y::b) = e
+ -- whereas this is ok
+ -- (x::Int, y::Bool) = e
+ --
+ -- We don't check explicitly for this problem. Instead, we simply
+ -- type check the pattern with tcPat. If the pattern mentions any
+ -- fresh tyvars we simply get an out-of-scope type variable error
tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
let
- complete_it = tcAddSrcLoc locn $
- tcAddErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSsAndBinds grhss_and_binds pat_ty PatBindRhs `thenTc` \ (grhss_and_binds', lie) ->
- returnTc (PatMonoBind pat' grhss_and_binds' locn, lie)
+ complete_it xve = tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ tcExtendLocalValEnv xve $
+ tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
+ returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
\end{code}
now (ToDo).
\begin{code}
-checkSigMatch []
- = returnTc (error "checkSigMatch", emptyLIE)
+checkSigMatch top_lvl binder_names mono_ids sigs
+ | main_bound_here
+ = mapTc check_one_sig sigs `thenTc_`
+ mapTc check_main_ctxt sigs `thenTc_`
+
+ -- Now unify the main_id with IO t, for any old t
+ tcSetErrCtxt mainTyCheckCtxt (
+ tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
+ unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
+ (idType main_mono_id)
+ ) `thenTc_`
+ returnTc (Just ([], emptyLIE))
+
+ | not (null sigs)
+ = mapTc check_one_sig sigs `thenTc_`
+ mapTc check_one_ctxt all_sigs_but_first `thenTc_`
+ returnTc (Just (theta1, sig_lie))
+
+ | otherwise
+ = returnTc Nothing -- No constraints from type sigs
+
+ where
+ (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
+
+ sig1_dict_tys = mk_dict_tys theta1
+ n_sig1_dict_tys = length sig1_dict_tys
+ sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
-checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first )
- = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
+ maybe_main = find_main top_lvl binder_names mono_ids
+ main_bound_here = maybeToBool maybe_main
+ Just main_mono_id = maybe_main
+
+ -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-- Doesn't affect substitution
- mapTc check_one_sig tc_ty_sigs `thenTc_`
+ check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
+ checkSigTyVars sig_tyvars
+
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
-- The type signatures on a mutually-recursive group of definitions
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
- mapTc check_one_cxt all_sigs_but_first `thenTc_`
-
- returnTc (theta1, sig_lie)
- where
- sig1_dict_tys = mk_dict_tys theta1
- n_sig1_dict_tys = length sig1_dict_tys
- sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs]
-
- check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+ check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
where
this_sig_dict_tys = mk_dict_tys theta
- check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (quotes (ppr id)) sig_tau) $
- checkSigTyVars sig_tyvars
+ -- CHECK THAT FOR A GROUP INVOLVING Main.main, all
+ -- the signature contexts are empty (what a bore)
+ check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ checkTc (null theta) (mainContextsErr id)
mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+
+ sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
+ nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+
+ -- Search for Main.main in the binder_names, return corresponding mono_id
+ find_main NotTopLevel binder_names mono_ids = Nothing
+ find_main TopLevel binder_names mono_ids = go binder_names mono_ids
+ go [] [] = Nothing
+ go (n:ns) (m:ms) | n == main_NAME = Just m
+ | otherwise = go ns ms
\end{code}
\begin{code}
tcPragmaSigs :: [RenamedSig] -- The pragma signatures
-> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
- TcMonoBinds s,
- LIE s)
+ TcMonoBinds,
+ LIE)
tcPragmaSigs sigs
= mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
a bit of overkill.
\begin{code}
-tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds, LIE)
tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsTcType poly_ty `thenTc` \ sig_ty ->
+ tcHsType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
-- It is the thing that makes sure we don't prematurely
-- dead-code-eliminate the binding we are really interested in.
newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
- returnTc (Nothing, VarMonoBind (TcId spec_id) spec_expr, spec_lie)
+ returnTc (Nothing, VarMonoBind spec_id spec_expr, spec_lie)
Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
-- Get the type of f, and find out what types
-- f has to be instantiated at to give the signature type
- tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
+ tcLookupValue name `thenNF_Tc` \ f_id ->
tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
let
-----------------------------------------------
valSpecSigCtxt v ty
= sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
- nest 4 (ppr v <+> ptext SLIT(" ::") <+> ppr ty)]
+ nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
notAsPolyAsSigErr sig_tau mono_tyvars
-----------------------------------------------
sigContextsErr
= ptext SLIT("Mismatched contexts")
+
sigContextsCtxt s1 s2
= hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+mainContextsErr id
+ | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
+ | otherwise
+ = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main")
+
+mainTyCheckCtxt
+ = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
+
-----------------------------------------------
unliftedBindErr flavour mbind
= hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))