%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\section[TcBinds]{TcBinds}
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds, tcPolyBinds,
TcPragFun, tcPrags, mkPragFun,
TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
import TcMatches ( tcGRHSsPat, tcMatchesFun )
import TcExpr ( tcMonoExpr )
import DynFlags
import HsSyn
import TcRnMonad
import Inst
import TcEnv
import TcUnify
import TcSimplify
import TcHsType
import TcPat
import TcMType
import TcType
import Coercion
import VarEnv
import TysPrim
import Id
import Var
import Name
import NameSet
import NameEnv
import VarSet
import SrcLoc
import Bag
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
import Outputable
import FastString
import Control.Monad
\end{code}
%************************************************************************
%* *
\subsection{Typechecking bindings}
%* *
%************************************************************************
@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them. So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
the scope of the bindings returning a typechecked thing and (most
important) an LIE. It is this LIE which is then used as the basis for
specialising the things bound.
@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".
The real work is done by @tcBindWithSigsAndThen@.
Recursive and nonrecursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left. The only
difference is that nonrecursive bindings can bind primitive values.
Even for nonrecursive binding groups we add typings for each binder
to the LVE for the following reason. When each individual binding is
checked the type of its LHS is unified with that of its RHS; and
typechecking the LHS of course requires that the binder is in scope.
At the toplevel the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.
\begin{code}
tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
tcTopBinds binds
= do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
; return (foldr (unionBags . snd) emptyBag prs, env) }
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
tcHsBootSigs (ValBindsOut binds sigs)
= do { checkTc (null binds) badBootDeclErr
; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkVanillaGlobal name sigma_ty) }
tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
badBootDeclErr :: Message
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
tcLocalBinds :: HsLocalBinds Name -> TcM thing
-> TcM (HsLocalBinds TcId, thing)
tcLocalBinds EmptyLocalBinds thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds, thing) }
tcLocalBinds (HsValBinds binds) thing_inside
= do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
; return (HsValBinds binds', thing) }
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { (thing, lie) <- getLIE thing_inside
; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
; dict_binds <- tcSimplifyIPs avail_ips lie
; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) }
where
tc_ip_bind (IPBind ip expr) = do
ty <- newFlexiTyVarTy argTypeKind
(ip', ip_inst) <- newIPDict (IPBindOrigin ip) ip ty
expr' <- tcMonoExpr expr ty
return (ip_inst, (IPBind ip' expr'))
tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-> TcM (HsValBinds TcId, thing)
tcValBinds _ (ValBindsIn binds _) _
= pprPanic "tcValBinds" (ppr binds)
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= do {
; let { prag_fn = mkPragFun sigs
; ty_sigs = filter isTypeLSig sigs
; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
tcBindGroups poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
tcBindGroups _ _ _ _ [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group poly_rec top_lvl sig_fn prag_fn group $
tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
-> (RecFlag, LHsBinds Name) -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
tc_group _ top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
= do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn
NonRecursive binds thing_inside
; return ( [(NonRecursive, unitBag b) | b <- bagToList binds1]
++ [(Recursive, lie_binds)]
, thing) }
tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
| not poly_rec
= do { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn
Recursive binds thing_inside
; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) }
| otherwise
=
do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
; (binds1,lie_binds,thing) <- bindLocalInsts top_lvl $
go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) }
where
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs
; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, [], thing) }
tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind)
tc_scc (CyclicSCC binds) = tc_sub_group Recursive (listToBag binds)
tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
tc_haskell98 :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag
-> LHsBinds Name -> TcM a -> TcM (LHsBinds TcId, TcDictBinds, a)
tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside
= bindLocalInsts top_lvl $
do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds
; thing <- tcExtendIdEnv ids thing_inside
; return (binds1, ids, thing) }
bindLocalInsts :: TopLevelFlag
-> TcM (LHsBinds TcId, [TcId], a)
-> TcM (LHsBinds TcId, TcDictBinds, a)
bindLocalInsts top_lvl thing_inside
| isTopLevel top_lvl
= do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) }
| otherwise
= do { ((binds, ids, thing), lie) <- getLIE thing_inside
; lie_binds <- bindInstsOfLocalFuns lie ids
; return (binds, lie_binds, thing) }
mkEdges :: TcSigFun -> LHsBinds Name
-> [(LHsBind Name, BKey, [BKey])]
type BKey = Int
mkEdges sig_fn binds
= [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ])
| (bind, key) <- keyd_binds
]
where
no_sig :: Name -> Bool
no_sig n = isNothing (sig_fn n)
keyd_binds = bagToList binds `zip` [0::BKey ..]
key_map :: NameEnv BKey
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind"
tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun
-> RecFlag
-> RecFlag
-> LHsBinds Name
-> TcM (LHsBinds TcId, [TcId])
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
= let
bind_list = bagToList binds
binder_names = collectHsBindBinders binds
loc = getLoc (head bind_list)
in
setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
{ traceTc (ptext (sLit "------------------------------------------------"))
; traceTc (ptext (sLit "Bindings for") <+> ppr binder_names)
; ((binds', mono_bind_infos), lie_req)
<- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req))
; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
; is_strict <- checkStrictBinds top_lvl rec_group binds'
zonked_mono_tys mono_bind_infos
; if is_strict then
do { extendLIEs lie_req
; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
mk_export (_, Just sig, mono_id) _ = ([], sig_id sig, mono_id, [])
; return ( unitBag $ L loc $ AbsBinds [] [] exports binds',
[poly_id | (_, poly_id, _, _) <- exports]) }
else do
{ dflags <- getDOpts
; (tyvars_to_gen, dicts, dict_binds)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
; let dict_vars = map instToVar dicts
; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars))
mono_bind_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
; let abs_bind = L loc $ AbsBinds tyvars_to_gen
dict_vars exports
(dict_binds `unionBags` binds')
; return (unitBag abs_bind, poly_ids)
} }
mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
-> MonoBindInfo
-> TcM ([TyVar], Id, Id, [LPrag])
mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
= do { warn_missing_sigs <- doptM Opt_WarnMissingSigs
; let warn = isTopLevel top_lvl && warn_missing_sigs
; (tvs, poly_id) <- mk_poly_id warn mb_sig
; prags <- tcPrags poly_id (prag_fn poly_name)
; return (tvs, poly_id, mono_id, prags) }
where
poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
mk_poly_id warn Nothing = do { poly_ty' <- zonkTcType poly_ty
; missingSigWarn warn poly_name poly_ty'
; return (inferred_tvs, mkLocalId poly_name poly_ty') }
mk_poly_id _ (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
; return (tvs, sig_id sig) }
zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
type TcPragFun = Name -> [LSig Name]
mkPragFun :: [LSig Name] -> TcPragFun
mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
where
prs = [(expectJust "mkPragFun" (sigName sig), sig)
| sig <- sigs, isPragLSig sig]
env = foldl add emptyNameEnv prs
add env (n,p) = extendNameEnv_Acc (:) singleton env n p
tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
where
tc_prag prag = addErrCtxt (pragSigCtxt prag) $
tcPrag poly_id prag
pragSigCtxt :: Sig Name -> SDoc
pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
tcPrag :: TcId -> Sig Name -> TcM Prag
tcPrag poly_id (SpecSig _ hs_ty inl)
= do { let name = idName poly_id
; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
tcPrag poly_id (SpecInstSig hs_ty)
= do { let name = idName poly_id
; (tyvars, theta, tau) <- tcHsInstHead hs_ty
; let spec_ty = mkSigmaTy tyvars theta tau
; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) }
tcPrag _ (InlineSig _ inl) = return (InlinePrag inl)
tcPrag _ sig = pprPanic "tcPrag" (ppr sig)
recoveryCode :: [Name] -> (Name -> Maybe [Name])
-> TcM (LHsBinds TcId, [Id])
recoveryCode binder_names sig_fn
= do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
; poly_ids <- mapM mk_dummy binder_names
; return (emptyBag, poly_ids) }
where
mk_dummy name
| isJust (sig_fn name) = tcLookupId name
| otherwise = return (mkLocalId name forall_a_a)
forall_a_a :: TcType
forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
checkStrictBinds :: TopLevelFlag -> RecFlag
-> LHsBinds TcId -> [TcType] -> [MonoBindInfo]
-> TcM Bool
checkStrictBinds top_lvl rec_group mbind mono_tys infos
| unlifted || bang_pat
= do { checkTc (isNotTopLevel top_lvl)
(strictBindErr "Top-level" unlifted mbind)
; checkTc (isNonRec rec_group)
(strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted mbind)
; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
; warnTc (warnUnlifted && not bang_pat)
(unliftedMustBeBang mbind)
; mapM_ check_sig infos
; return True }
| otherwise
= return False
where
unlifted = any isUnLiftedType mono_tys
bang_pat = anyBag (isBangHsBind . unLoc) mbind
check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
(badStrictSig unlifted sig)
check_sig _ = return ()
unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
unliftedMustBeBang mbind
= hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
4 (pprLHsBinds mbind)
$$ text "*** This will be an error in GHC 6.14! Fix your code now!"
strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
4 (pprLHsBinds mbind)
where
msg | unlifted = ptext (sLit "bindings for unlifted types")
| otherwise = ptext (sLit "bang-pattern bindings")
badStrictSig :: Bool -> TcSigInfo -> SDoc
badStrictSig unlifted sig
= hang (ptext (sLit "Illegal polymorphic signature in") <+> msg)
4 (ppr sig)
where
msg | unlifted = ptext (sLit "an unlifted binding")
| otherwise = ptext (sLit "a bang-pattern binding")
\end{code}
%************************************************************************
%* *
\subsection{tcMonoBind}
%* *
%************************************************************************
@tcMonoBinds@ deals with a perhapsrecursive group of HsBinds.
The signatures have been dealt with already.
\begin{code}
tcMonoBinds :: [LHsBind Name]
-> TcSigFun
-> RecFlag
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
fun_matches = matches, bind_fvs = fvs })]
sig_fn
NonRecursive
| Nothing <- sig_fn name
=
setSrcSpan b_loc $
do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
; zonked_rhs_ty <- zonkTcType rhs_ty
; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
(unboxedTupleErr name zonked_rhs_ty)
; mono_name <- newLocalName name
; let mono_id = mkLocalId mono_name zonked_rhs_ty
; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
fun_matches = matches', bind_fvs = fvs,
fun_co_fn = co_fn, fun_tick = Nothing })),
[(name, Nothing, mono_id)]) }
tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
fun_matches = matches })]
sig_fn
_
| Just scoped_tvs <- sig_fn name
=
setSrcSpan b_loc $
do { tc_sig <- tcInstSig True name
; mono_name <- newLocalName name
; let mono_ty = sig_tau tc_sig
mono_id = mkLocalId mono_name mono_ty
rhs_tvs = [ (name, mkTyVarTy tv)
| (name, tv) <- scoped_tvs `zip` sig_tvs tc_sig ]
; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
tcMatchesFun mono_name inf matches mono_ty
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
bind_fvs = placeHolderNames, fun_co_fn = co_fn,
fun_tick = Nothing }
; return (unitBag (L b_loc fun_bind'),
[(name, Just tc_sig, mono_id)]) }
tcMonoBinds binds sig_fn _
= do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
; let mono_info = getMonoBindInfo tc_binds
rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
; binds' <- tcExtendIdEnv2 rhs_id_env $ do
traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env])
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_info) }
data TcMonoBind
= TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
| TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
bndrNames :: [MonoBindInfo] -> [Name]
bndrNames mbi = [n | (n,_,_) <- mbi]
getMonoType :: MonoBindInfo -> TcTauType
getMonoType (_,_,mono_id) = idType mono_id
tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
= do { mb_sig <- tcInstSig_maybe sig_fn name
; mono_name <- newLocalName name
; mono_ty <- mk_mono_ty mb_sig
; let mono_id = mkLocalId mono_name mono_ty
; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
where
mk_mono_ty (Just sig) = return (sig_tau sig)
mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind
tcLhs sig_fn (PatBind { pat_lhs = pat, pat_rhs = grhss })
= do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names
; mono_pat_binds <- doptM Opt_MonoPatBinds
; let nm_sig_prs = names `zip` mb_sigs
get_sig_ty | mono_pat_binds = idType . sig_id
| otherwise = sig_tau
tau_sig_env = mkNameEnv [ (name, get_sig_ty sig)
| (name, Just sig) <- nm_sig_prs]
sig_tau_fn = lookupNameEnv tau_sig_env
tc_pat exp_ty = tcLetPat sig_tau_fn pat exp_ty $
mapM lookup_info nm_sig_prs
lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo
lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name
; return (name, mb_sig, mono_id) }
; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
tcInfer tc_pat
; return (TcPatBind infos pat' grhss pat_ty) }
where
names = collectPatBinders pat
tcLhs _ other_bind = pprPanic "tcLhs" (ppr other_bind)
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
tcRhs (TcFunBind (_,_,mono_id) fun' inf matches)
= do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
matches (idType mono_id)
; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
bind_fvs = placeHolderNames, fun_co_fn = co_fn,
fun_tick = Nothing }) }
tcRhs (TcPatBind _ pat' grhss pat_ty)
= do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcGRHSsPat grhss pat_ty
; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty,
bind_fvs = placeHolderNames }) }
getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo tc_binds
= foldr (get_info . unLoc) [] tc_binds
where
get_info (TcFunBind info _ _ _) rest = info : rest
get_info (TcPatBind infos _ _ _) rest = infos ++ rest
\end{code}
%************************************************************************
%* *
Generalisation
%* *
%************************************************************************
\begin{code}
generalise :: DynFlags -> TopLevelFlag
-> [LHsBind Name] -> TcSigFun
-> [MonoBindInfo] -> [Inst]
-> TcM ([TyVar], [Inst], TcDictBinds)
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
| isMonoGroup dflags top_lvl bind_list sigs
= do { extendLIEs lie_req
; return ([], [], emptyBag) }
| isRestrictedGroup dflags bind_list sig_fn
=
do { checkTc (all is_mono_sig sigs)
(restrictedBindCtxtErr bndrs)
; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs
tau_tvs lie_req
; final_qtvs <- checkSigsTyVars qtvs sigs
; return (final_qtvs, [], binds) }
| null sigs
= tcSimplifyInfer doc tau_tvs lie_req
| otherwise
= do { sig_lie <- unifyCtxts sigs
; let
local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
sig_avails = sig_lie ++ local_meths
loc = sig_loc (head sigs)
; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
; final_qtvs <- checkSigsTyVars qtvs sigs
; return (final_qtvs, sig_lie, binds) }
where
bndrs = bndrNames mono_infos
sigs = [sig | (_, Just sig, _) <- mono_infos]
get_tvs | isTopLevel top_lvl = tyVarsOfType
| otherwise = exactTyVarsOfType
tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
is_mono_sig sig = null (sig_theta sig)
doc = ptext (sLit "type signature(s) for") <+> pprBinders bndrs
mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
sig_theta = theta, sig_loc = loc }) mono_id
= Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs,
tci_theta = theta, tci_loc = loc}
\end{code}
unifyCtxts checks that all the signature contexts are the same
The type signatures on a mutuallyrecursive group of definitions
must all have the same context (or none).
The trick here is that all the signatures should have the same
context, and we want to share type variables for that context, so that
all the right hand sides agree a common vocabulary for their type
constraints
We unify them because, with polymorphic recursion, their types
might not otherwise be related. This is a rather subtle issue.
\begin{code}
unifyCtxts :: [TcSigInfo] -> TcM [Inst]
unifyCtxts [] = panic "unifyCtxts []"
unifyCtxts (sig1 : sigs)
= do { traceTc $ text "unifyCtxts" <+> ppr (sig1 : sigs)
; mapM_ unify_ctxt sigs
; theta <- zonkTcThetaType (sig_theta sig1)
; newDictBndrs (sig_loc sig1) theta }
where
theta1 = sig_theta sig1
unify_ctxt :: TcSigInfo -> TcM ()
unify_ctxt sig@(TcSigInfo { sig_theta = theta })
= setSrcSpan (instLocSpan (sig_loc sig)) $
addErrCtxt (sigContextsCtxt sig1 sig) $
do { cois <- unifyTheta theta1 theta
;
checkTc (all isIdentityCoI cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
= do { gbl_tvs <- tcGetGlobalTyVars
; sig_tvs_s <- mapM (check_sig gbl_tvs) sigs
; let
sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
; return all_tvs }
where
check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau})
= addErrCtxt (ptext (sLit "In the type signature for") <+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id tvs theta tau) $
do { tvs' <- checkDistinctTyVars tvs
; when (any (`elemVarSet` gbl_tvs) tvs')
(bleatEscapedTvs gbl_tvs tvs tvs')
; return tvs' }
checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
checkDistinctTyVars sig_tvs
= do { zonked_tvs <- mapM zonkSigTyVar sig_tvs
; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
; return zonked_tvs }
where
check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
check_dup acc (sig_tv, zonked_tv)
= case lookupVarEnv acc zonked_tv of
Just sig_tv' -> bomb_out sig_tv sig_tv'
Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
bomb_out sig_tv1 sig_tv2
= do { env0 <- tcInitTidyEnv
; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1
(env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
msg = ptext (sLit "Quantified type variable") <+> quotes (ppr tidy_tv1)
<+> ptext (sLit "is unified with another quantified type variable")
<+> quotes (ppr tidy_tv2)
; failWithTcM (env2, msg) }
\end{code}
@getTyVarsToGen@ decides what type variables to generalise over.
For a "restricted group"
for a definition
remove from tyvars_to_gen any constrained type variables
*Don't* simplify dicts at this point, because we aren't going
to generalise over these dicts. By the time we do simplify them
we may well know more. For example (this actually came up)
f :: Array Int Int
f x = array ... xs where xs = [1,2,3,4,5]
We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
stuff. If we simplify only at the fbinding (not the xsbinding)
we'll know that the literals are all Ints, and we can just produce
Int literals!
Find all the type variables involved in overloading, the
"constrained_tyvars". These are the ones we *aren't* going to
generalise. We must be careful about doing this:
(a) If we fail to generalise a tyvar which is not actually
constrained, then it will never, ever get bound, and lands
up printed out in interface files! Notorious example:
instance Eq a => Eq (Foo a b) where ..
Here, b is not constrained, even though it looks as if it is.
Another, more common, example is when there's a Method inst in
the LIE, whose type might very well involve nonoverloaded
type variables.
[NOTE: Jan 2001: I don't understand the problem here so I'm doing
the simple thing instead]
(b) On the other hand, we mustn't generalise tyvars which are constrained,
because we are going to pass on out the unmodified LIE, with those
tyvars in it. They won't be in scope if we've generalised them.
So we are careful, and do a complete simplification just to find the
constrained tyvars. We don't use any of the results, except to
find which tyvars are constrained.
Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is
* Bind any variable for which we have a type signature
to an Id with a polymorphic type. Then when typechecking
the RHSs we'll make a full polymorphic call.
This fine, but if you aren't a bit careful you end up with a horrendous
amount of partial application and (worse) a huge space leak. For example:
f :: Eq a => [a] -> [a]
f xs = ...f...
If we don't take care, after typechecking we get
f = /\a -> \d::Eq a -> let f' = f a d
in
\ys:[a] -> ...f'...
Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing. In this case, the
polymorphic recursion isn't being used (but that's a very common case).
This can lead to a massive space leak, from the following toplevel defn
(posttypechecking)
ff :: [Int] -> [Int]
ff = f Int dEqInt
Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.
ff = f Int dEqInt
= let f' = f Int dEqInt in \ys. ...f'...
= let f' = let f' = f Int dEqInt in \ys. ...f'...
in \ys. ...f'...
Etc.
NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
which would make the space leak go away in this case
Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding. So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id. We achieve this by adding monomorphic Ids
to the "givens" when simplifying constraints. That's what the "lies_avail"
is doing.
Then we get
f = /\a -> \d::Eq a -> letrec
fm = \ys:[a] -> ...fm...
in
fm
%************************************************************************
%* *
Signatures
%* *
%************************************************************************
Type signatures are tricky. See Note [Signature skolems] in TcType
@tcSigs@ checks the signatures for validity, and returns a list of
{\em freshlyinstantiated} signatures. That is, the types are already
split up, and have fresh type variables installed. All nontypesignature
"RenamedSigs" are ignored.
The @TcSigInfo@ contains @TcTypes@ because they are unified with
the variable's type, and after that checked to see whether they've
been instantiated.
Note [Scoped tyvars]
~~~~~~~~~~~~~~~~~~~~
The XScopedTypeVariables flag brings lexicallyscoped type variables
into scope for any explicitly forallquantified type variables:
f :: forall a. a -> a
f x = e
Then 'a' is in scope inside 'e'.
However, we do *not* support this
For pattern bindings e.g
f :: forall a. a->a
(f,g) = e
For multiple function bindings, unless Opt_RelaxedPolyRec is on
f :: forall a. a -> a
f = g
g :: forall b. b -> b
g = ...f...
Reason: we use mutable variables for 'a' and 'b', since they may
unify to each other, and that means the scoped type variable would
not stand for a completely rigid variable.
Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec
Note [More instantiated than scoped]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There may be more instantiated type variables than lexicallyscoped
ones. For example:
type T a = forall b. b -> (a,b)
f :: forall c. T c
Here, the signature for f will have one scoped type variable, c,
but two instantiated type variables, c' and b'.
We assume that the scoped ones are at the *front* of sig_tvs,
and remember the names from the original HsForAllTy in the TcSigFun.
\begin{code}
type TcSigFun = Name -> Maybe [Name]
mkTcSigFun :: [LSig Name] -> TcSigFun
mkTcSigFun sigs = lookupNameEnv env
where
env = mkNameEnv (mapCatMaybes mk_pair sigs)
mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty)
mk_pair (L _ (IdSig id)) = Just (idName id, [])
mk_pair _ = Nothing
data TcSigInfo
= TcSigInfo {
sig_id :: TcId,
sig_tvs :: [TcTyVar],
sig_theta :: TcThetaType,
sig_tau :: TcTauType,
sig_loc :: InstLoc
}
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
= ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> ppr theta <+> ptext (sLit "=>") <+> ppr tau
\end{code}
\begin{code}
tcTySig :: LSig Name -> TcM TcId
tcTySig (L span (TypeSig (L _ name) ty))
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkLocalId name sigma_ty) }
tcTySig (L _ (IdSig id))
= return id
tcTySig s = pprPanic "tcTySig" (ppr s)
tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo)
tcInstSig_maybe sig_fn name
= case sig_fn name of
Nothing -> return Nothing
Just _scoped_tvs -> do { tc_sig <- tcInstSig False name
; return (Just tc_sig) }
tcInstSig :: Bool -> Name -> TcM TcSigInfo
tcInstSig use_skols name
= do { poly_id <- tcLookupId name
; let skol_info = SigSkol (FunSigCtxt name)
; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
; loc <- getInstLoc (SigOrigin skol_info)
; return (TcSigInfo { sig_id = poly_id,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
sig_loc = loc }) }
isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
-> [TcSigInfo] -> Bool
isMonoGroup dflags top_lvl binds sigs
= (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
|| (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
where
is_pat_bind (L _ (PatBind {})) = True
is_pat_bind _ = False
isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool
isRestrictedGroup dflags binds sig_fn
= mono_restriction && not all_unrestricted
where
mono_restriction = dopt Opt_MonomorphismRestriction dflags
all_unrestricted = all (unrestricted . unLoc) binds
has_sig n = isJust (sig_fn n)
unrestricted (PatBind {}) = False
unrestricted (VarBind { var_id = v }) = has_sig v
unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches
|| has_sig (unLoc v)
unrestricted (AbsBinds {})
= panic "isRestrictedGroup/unrestricted AbsBinds"
unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
unrestricted_match _ = True
\end{code}
%************************************************************************
%* *
\subsection[TcBindserrors]{Error contexts and messages}
%* *
%************************************************************************
\begin{code}
patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc
patMonoBindsCtxt pat grhss
= hang (ptext (sLit "In a pattern binding:")) 4 (pprPatBind pat grhss)
sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
sigContextsCtxt sig1 sig2
= vcat [ptext (sLit "When matching the contexts of the signatures for"),
nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
ppr id2 <+> dcolon <+> ppr (idType id2)]),
ptext (sLit "The signature contexts in a mutually recursive group should all be identical")]
where
id1 = sig_id sig1
id2 = sig_id sig2
unboxedTupleErr :: Name -> Type -> SDoc
unboxedTupleErr name ty
= hang (ptext (sLit "Illegal binding of unboxed tuple"))
4 (ppr name <+> dcolon <+> ppr ty)
restrictedBindCtxtErr :: [Name] -> SDoc
restrictedBindCtxtErr binder_names
= hang (ptext (sLit "Illegal overloaded type signature(s)"))
4 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names,
ptext (sLit "that falls under the monomorphism restriction")])
genCtxt :: [Name] -> SDoc
genCtxt binder_names
= ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names
missingSigWarn :: Bool -> Name -> Type -> TcM ()
missingSigWarn False _ _ = return ()
missingSigWarn True name ty
= do { env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 ty
; addWarnTcM (env1, mk_msg tidy_ty) }
where
mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name),
sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]]
\end{code}