module GHC.Tc.Gen.Bind
( tcLocalBinds
, tcTopBinds
, tcValBinds
, tcHsBootSigs
, tcPolyCheck
, chooseInferredQuantifiers
, badBootDeclErr
)
where
import GHC.Prelude
import GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
import GHC.Tc.Gen.Expr ( tcCheckMonoExpr )
import GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import GHC.Core (Tickish (..))
import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Hs
import GHC.Tc.Gen.Sig
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify
import GHC.Tc.Solver
import GHC.Tc.Types.Evidence
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types( mkBoxedTupleTy )
import GHC.Types.Id
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env( TidyEnv )
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Utils.Error
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Utils.Outputable as Outputable
import GHC.Builtin.Names( ipClassName )
import GHC.Tc.Validity (checkValidType)
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.ConLike
import Control.Monad
import Data.Foldable (find)
#include "HsVersions.h"
tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
tcTopBinds binds sigs
= do {
(binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
do { gbl <- getGblEnv
; lcl <- getLclEnv
; return (gbl, lcl) }
; specs <- tcImpPrags sigs
; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
; traceTc "complete_matches" (ppr binds $$ ppr sigs)
; traceTc "complete_matches" (ppr complete_matches)
; let { tcg_env' = tcg_env { tcg_imp_specs
= specs ++ tcg_imp_specs tcg_env
, tcg_complete_matches
= complete_matches
++ tcg_complete_matches tcg_env }
`addTypecheckedBinds` map snd binds' }
; return (tcg_env', tcl_env) }
data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon
tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs sigs =
let
doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
doOne c@(CompleteMatchSig _ _ lns mtc)
= fmap Just $ do
addErrCtxt (text "In" <+> ppr c) $
case mtc of
Nothing -> infer_complete_match
Just tc -> check_complete_match tc
where
checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
infer_complete_match = do
(res, cls) <- checkCLTypes AcceptAny
case res of
AcceptAny -> failWithTc ambiguousError
Fixed _ tc -> return $ mkMatch cls tc
check_complete_match tc_name = do
ty_con <- tcLookupLocatedTyCon tc_name
(_, cls) <- checkCLTypes (Fixed Nothing ty_con)
return $ mkMatch cls ty_con
mkMatch :: [ConLike] -> TyCon -> CompleteMatch
mkMatch cls ty_con = CompleteMatch {
completeMatchConLikes = reverse (map conLikeName cls),
completeMatchTyCon = tyConName ty_con
}
doOne _ = return Nothing
ambiguousError :: SDoc
ambiguousError =
text "A type signature must be provided for a set of polymorphic"
<+> text "pattern synonyms."
checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
-> TcM (CompleteSigType, [ConLike])
checkCLType (cst, cs) n = do
cl <- addLocM tcLookupConLike n
let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
res_ty_con = fst <$> splitTyConApp_maybe res_ty
case (cst, res_ty_con) of
(AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
(AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
(Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs)
(Fixed mfcl tc, Just tc') ->
if tc == tc'
then return (Fixed mfcl tc, cl:cs)
else case mfcl of
Nothing ->
addErrCtxt (text "In" <+> ppr cl) $
failWithTc typeSigErrMsg
Just cl -> failWithTc (errMsg cl)
where
typeSigErrMsg :: SDoc
typeSigErrMsg =
text "Couldn't match expected type"
<+> quotes (ppr tc)
<+> text "with"
<+> quotes (ppr tc')
errMsg :: ConLike -> SDoc
errMsg fcl =
text "Cannot form a group of complete patterns from patterns"
<+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
<+> text "as they match different type constructors"
<+> parens (quotes (ppr tc)
<+> text "resp."
<+> quotes (ppr tc'))
in mapMaybeM (addLocM doOne) (reverse sigs)
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs binds sigs
= do { checkTc (null binds) badBootDeclErr
; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
f (L _ name)
= do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
; return (mkVanillaGlobal name sigma_ty) }
tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
badBootDeclErr :: MsgDoc
badBootDeclErr = text "Illegal declarations in an hs-boot file"
tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
-> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds (EmptyLocalBinds x) thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds x, thing) }
tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
= do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
= do { ipClass <- tcLookupClass ipClassName
; (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
; (ev_binds, result) <- checkConstraints (IPSkol ips)
[] given_ips thing_inside
; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
where
ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds]
tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)
= do { ty <- newOpenFlexiTyVarTy
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcCheckMonoExpr expr ty
; let d = toDict ipClass p ty `fmap` expr'
; return (ip_id, (IPBind noExtField (Right ip_id) d)) }
tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds top_lvl binds sigs thing_inside
= do {
(poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
tcTySigs sigs
; tcExtendSigIds top_lvl poly_ids $
do { (binds', (extra_binds', thing))
<- tcBindGroups top_lvl sig_fn prag_fn binds $
do { thing <- thing_inside
; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
; let extra_binds = [ (NonRecursive, builder)
| builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
where
patsyns = getPatSynBinds binds
prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcBindGroups _ _ _ [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
= do {
type_env <- getLclTypeEnv
; let closed = isClosedBndrGroup type_env (snd group)
; (group', (groups', thing))
<- tc_group top_lvl sig_fn prag_fn group closed $
tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
= do { let bind = case bagToList binds of
[bind] -> bind
[] -> panic "tc_group: empty list of binds"
_ -> panic "tc_group: NonRecursive binds is not a singleton bag"
; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
thing_inside
; return ( [(NonRecursive, bind')], thing) }
tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
=
do { traceTc "tc_group rec" (pprLHsBinds binds)
; whenIsJust mbFirstPatSyn $ \lpat_syn ->
recursivePatSynErr (getLoc lpat_syn) binds
; (binds1, thing) <- go sccs
; return ([(Recursive, binds1)], thing) }
where
mbFirstPatSyn = find (isPatSyn . unLoc) binds
isPatSyn PatSynBind{} = True
isPatSyn _ = False
sccs :: [SCC (LHsBind GhcRn)]
sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1
(go sccs)
; return (binds1 `unionBags` binds2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, thing) }
tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
tc_sub_group rec_tc binds =
tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr ::
(OutputableBndrId p, CollectPass (GhcPass p))
=> SrcSpan
-> LHsBinds (GhcPass p)
-> TcM a
recursivePatSynErr loc binds
= failAt loc $
hang (text "Recursive pattern synonym definition with following bindings:")
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (text "defined at" <+> ppr loc)
pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
<+> pprLoc loc
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind GhcRn -> IsGroupClosed -> TcM thing
-> TcM (LHsBinds GhcTc, thing)
tc_single _top_lvl sig_fn _prag_fn
(L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
_ thing_inside
= do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
; thing <- setGblEnv tcg_env thing_inside
; return (aux_binds, thing)
}
tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
= do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
NonRecursive NonRecursive
closed
[lbind]
; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
; return (binds1, thing) }
type BKey = Int
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
mkEdges sig_fn binds
= [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ]
| (bind, key) <- keyd_binds
]
where
bind_fvs (FunBind { fun_ext = fvs }) = fvs
bind_fvs (PatBind { pat_ext = fvs }) = fvs
bind_fvs _ = emptyNameSet
no_sig :: Name -> Bool
no_sig n = not (hasCompleteSig 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 <- collectHsBindBinders bind ]
tcPolyBinds :: TcSigFun -> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
= setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
{ traceTc "------------------------------------------------" Outputable.empty
; traceTc "Bindings for {" (ppr binder_names)
; dflags <- getDynFlags
; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
; traceTc "Generalisation plan" (ppr plan)
; result@(_, poly_ids) <- case plan of
NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
, vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
])
; return result }
where
binder_names = collectHsBindListBinders bind_list
loc = foldr1 combineSrcSpans (map getLoc bind_list)
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
recoveryCode binder_names sig_fn
= do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
; let poly_ids = map mk_dummy binder_names
; return (emptyBag, poly_ids) }
where
mk_dummy name
| Just sig <- sig_fn name
, Just poly_id <- completeSigPolyId_maybe sig
= poly_id
| otherwise
= mkLocalId name Many forall_a_a
forall_a_a :: TcType
forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
tcPolyNoGen
:: RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
= do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
(LetGblBndr prag_fn)
bind_list
; mono_ids' <- mapM tc_mono_info mono_infos
; return (binds', mono_ids') }
where
tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
= do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
; return mono_id }
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo
-> LHsBind GhcRn
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyCheck prag_fn
(CompleteSig { sig_bndr = poly_id
, sig_ctxt = ctxt
, sig_loc = sig_loc })
(L bind_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
= do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
; mono_name <- newNameAt (nameOccName name) nm_loc
; (wrap_gen, (wrap_res, matches'))
<- setSrcSpan sig_loc $
tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->
let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
setSrcSpan bind_loc $
tcMatchesFun (L nm_loc mono_name) matches
(mkCheckExpType rho_ty)
; let prag_sigs = lookupPragEnv prag_fn name
poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id)
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
; tick <- funBindTicks nm_loc poly_id mod prag_sigs
; let bind' = FunBind { fun_id = L nm_loc poly_id2
, fun_matches = matches'
, fun_ext = wrap_gen <.> wrap_res
, fun_tick = tick }
export = ABE { abe_ext = noExtField
, abe_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = poly_id2
, abe_prags = SpecPrags spec_prags }
abs_bind = L bind_loc $
AbsBinds { abs_ext = noExtField
, abs_tvs = []
, abs_ev_vars = []
, abs_ev_binds = []
, abs_exports = [export]
, abs_binds = unitBag (L bind_loc bind')
, abs_sig = True }
; return (unitBag abs_bind, [poly_id]) }
tcPolyCheck _prag_fn sig bind
= pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [Tickish TcId]
funBindTicks loc fun_id mod sigs
| (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
, let cc_str
| Just cc_str <- mb_cc_str
= sl_fs $ unLoc cc_str
| otherwise
= getOccFS (Var.varName fun_id)
cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
= do
flavour <- DeclCC <$> getCCIndexM cc_name
let cc = mkUserCC cc_name mod loc flavour
return [ProfNote cc True True]
| otherwise
= return []
tcPolyInfer
:: RecFlag
-> TcPragEnv -> TcSigFun
-> Bool
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
= do { (tclvl, wanted, (binds', mono_infos))
<- pushLevelAndCaptureConstraints $
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
| info <- mono_infos ]
sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
infer_mode = if mono then ApplyMR else NoRestrictions
; mapM_ (checkOverloadedSig mono) sigs
; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
; (qtvs, givens, ev_binds, residual, insoluble)
<- simplifyInfer tclvl infer_mode sigs name_taus wanted
; emitConstraints residual
; let inferred_theta = map evVarPred givens
; exports <- checkNoErrs $
mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
; loc <- getSrcSpanM
; let poly_ids = map abe_poly exports
abs_bind = L loc $
AbsBinds { abs_ext = noExtField
, abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = [ev_binds]
, abs_exports = exports, abs_binds = binds'
, abs_sig = False }
; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
; return (unitBag abs_bind, poly_ids) }
mkExport :: TcPragEnv
-> Bool
-> [TyVar] -> TcThetaType
-> MonoBindInfo
-> TcM (ABExport GhcTc)
mkExport prag_fn insoluble qtvs theta
mono_info@(MBI { mbi_poly_name = poly_name
, mbi_sig = mb_sig
, mbi_mono_id = mono_id })
= do { mono_ty <- zonkTcType (idType mono_id)
; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
; poly_id <- addInlinePrags poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs
; let poly_ty = idType poly_id
sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
; wrap <- if sel_poly_ty `eqType` poly_ty
then return idHsWrapper
else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty
; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
; when warn_missing_sigs $
localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
; return (ABE { abe_ext = noExtField
, abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }) }
where
prag_sigs = lookupPragEnv prag_fn poly_name
sig_ctxt = InfSigCtxt poly_name
mkInferredPolyId :: Bool
-> [TyVar] -> TcThetaType
-> Name -> Maybe TcIdSigInst -> TcType
-> TcM TcId
mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
| Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
, CompleteSig { sig_bndr = poly_id } <- sig
= return poly_id
| otherwise
= checkNoErrs $
do { fam_envs <- tcGetFamInstEnvs
; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
; (binders, theta') <- chooseInferredQuantifiers inferred_theta
(tyCoVarsOfType mono_ty') qtvs mb_sig_inst
; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty')
; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
, ppr inferred_poly_ty])
; unless insoluble $
addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
checkValidType (InfSigCtxt poly_name) inferred_poly_ty
; return (mkLocalId poly_name Many inferred_poly_ty) }
chooseInferredQuantifiers :: TcThetaType
-> TcTyVarSet
-> [TcTyVar]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], TcThetaType)
chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
=
do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
my_theta = pickCapturedPreds free_tvs inferred_theta
binders = [ mkTyVarBinder InferredSpec tv
| tv <- qtvs
, tv `elemVarSet` free_tvs ]
; return (binders, my_theta) }
chooseInferredQuantifiers inferred_theta tau_tvs qtvs
(Just (TISI { sig_inst_sig = sig
, sig_inst_wcx = wcx
, sig_inst_theta = annotated_theta
, sig_inst_skols = annotated_tvs }))
=
do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs
; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs
; let psig_qtvs = map binderVar psig_qtv_bndrs
psig_qtv_set = mkVarSet psig_qtvs
psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs
; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs)
; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
, not (tv `elem` qtvs) ]
; annotated_theta <- zonkTcTypes annotated_theta
; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
; let keep_me = free_tvs `unionVarSet` psig_qtv_set
final_qtvs = [ mkTyVarBinder vis tv
| tv <- qtvs
, tv `elemVarSet` keep_me
, let vis = case lookupVarBndr tv psig_qtv_bndrs of
Just spec -> spec
Nothing -> InferredSpec ]
; return (final_qtvs, my_theta) }
where
report_dup_tyvar_tv_err (n1,n2)
| PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
= addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
<+> text "with" <+> quotes (ppr n2))
2 (hang (text "both bound by the partial type signature:")
2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
| otherwise
= pprPanic "report_tyvar_tv_err" (ppr sig)
report_mono_sig_tv_err n
| PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
= addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
2 (hang (text "bound by the partial type signature:")
2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
| otherwise
= pprPanic "report_mono_sig_tv_err" (ppr sig)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
choose_psig_context _ annotated_theta Nothing
= do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
`unionVarSet` tau_tvs)
; return (free_tvs, annotated_theta) }
choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
= do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
seed_tvs = tyCoVarsOfTypes annotated_theta
`unionVarSet` tau_tvs
; let keep_me = psig_qtvs `unionVarSet` free_tvs
my_theta = pickCapturedPreds keep_me inferred_theta
; let inferred_diff = [ pred
| pred <- my_theta
, all (not . (`eqType` pred)) annotated_theta ]
; ctuple <- mk_ctuple inferred_diff
; case tcGetCastedTyVar_maybe wc_var_ty of
Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
; traceTc "completeTheta" $
vcat [ ppr sig
, ppr annotated_theta, ppr inferred_theta
, ppr inferred_diff ]
; return (free_tvs, my_theta) }
mk_ctuple preds = return (mkBoxedTupleTy preds)
mk_impedance_match_msg :: MonoBindInfo
-> TcType -> TcType
-> TidyEnv -> TcM (TidyEnv, SDoc)
mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
inf_ty sig_ty tidy_env
= do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty
; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
; let msg = vcat [ text "When checking that the inferred type"
, nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
, text "is as general as its" <+> what <+> text "signature"
, nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
; return (tidy_env2, msg) }
where
what = case mb_sig of
Nothing -> text "inferred"
Just sig | isPartialSig sig -> text "(partial)"
| otherwise -> empty
mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg poly_name poly_ty tidy_env
= do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
; let msg = vcat [ text "When checking the inferred type"
, nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
; return (tidy_env1, msg) }
localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn flag id mb_sig
| Just _ <- mb_sig = return ()
| not (isSigmaTy (idType id)) = return ()
| otherwise = warnMissingSignatures flag msg id
where
msg = text "Polymorphic local binding with no type signature:"
warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
warnMissingSignatures flag msg id
= do { env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
where
mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
checkOverloadedSig monomorphism_restriction_applies sig
| not (null (sig_inst_theta sig))
, monomorphism_restriction_applies
, let orig_sig = sig_inst_sig sig
= setSrcSpan (sig_loc orig_sig) $
failWith $
hang (text "Overloaded signature conflicts with monomorphism restriction")
2 (ppr orig_sig)
| otherwise
= return ()
data MonoBindInfo = MBI { mbi_poly_name :: Name
, mbi_sig :: Maybe TcIdSigInst
, mbi_mono_id :: TcId }
tcMonoBinds :: RecFlag
-> TcSigFun -> LetBndrSpec
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
[ L b_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches })]
| NonRecursive <- is_rec
, Nothing <- sig_fn name
=
setSrcSpan b_loc $
do { ((co_fn, matches'), rhs_ty)
<- tcInfer $ \ exp_ty ->
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
tcMatchesFun (L nm_loc name) matches exp_ty
; mono_id <- newLetBndr no_gen name Many rhs_ty
; return (unitBag $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches',
fun_ext = co_fn, fun_tick = [] },
[MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }]) }
tcMonoBinds _ sig_fn no_gen binds
= do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
; let mono_infos = getMonoBindInfo tc_binds
rhs_id_env = [ (name, mono_id)
| MBI { mbi_poly_name = name
, mbi_sig = mb_sig
, mbi_mono_id = mono_id } <- mono_infos
, case mb_sig of
Just sig -> isPartialSig sig
Nothing -> True ]
; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]
; binds' <- tcExtendRecIds rhs_id_env $
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_infos) }
data TcMonoBind
= TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
| TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))
TcSigmaType
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
, fun_matches = matches })
| Just (TcIdSig sig) <- sig_fn name
=
do { mono_info <- tcLhsSigId no_gen (name, sig)
; return (TcFunBind mono_info nm_loc matches) }
| otherwise
= do { mono_ty <- newOpenFlexiTyVarTy
; mono_id <- newLetBndr no_gen name Many mono_ty
; let mono_info = MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }
; return (TcFunBind mono_info nm_loc matches) }
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
=
do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
[ (mbi_poly_name mbi, mbi_mono_id mbi)
| mbi <- sig_mbis ]
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (patMonoBindsCtxt pat grhss) $
tcInfer $ \ exp_ty ->
tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $
mapM lookup_info nosig_names
; let mbis = sig_mbis ++ nosig_mbis
; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
| mbi <- mbis, let id = mbi_mono_id mbi ]
$$ ppr no_gen)
; return (TcPatBind mbis pat' grhss pat_ty) }
where
bndr_names = collectPatBinders pat
(nosig_names, sig_names) = partitionWith find_sig bndr_names
find_sig :: Name -> Either Name (Name, TcIdSigInfo)
find_sig name = case sig_fn name of
Just (TcIdSig sig) -> Right (name, sig)
_ -> Left name
lookup_info :: Name -> TcM MonoBindInfo
lookup_info name
= do { mono_id <- tcLookupId name
; return (MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }) }
tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId no_gen (name, sig)
= do { inst_sig <- tcInstSig sig
; mono_id <- newSigLetBndr no_gen name inst_sig
; return (MBI { mbi_poly_name = name
, mbi_sig = Just inst_sig
, mbi_mono_id = mono_id }) }
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
| CompleteSig { sig_bndr = poly_id } <- id_sig
= addInlinePrags poly_id (lookupPragEnv prags name)
newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
= newLetBndr no_gen name Many tau
tcRhs :: TcMonoBind -> TcM (HsBind GhcTc)
tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
loc matches)
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
; return ( FunBind { fun_id = L loc mono_id
, fun_matches = matches'
, fun_ext = co_fn
, fun_tick = [] } ) }
tcRhs (TcPatBind infos pat' grhss pat_ty)
=
tcExtendIdBinderStackForRhs infos $
do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcScalingUsage Many $
tcGRHSsPat grhss pat_ty
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
, pat_ext = NPatBindTc emptyNameSet pat_ty
, pat_ticks = ([],[]) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Nothing thing_inside
= thing_inside
tcExtendTyVarEnvForRhs (Just sig) thing_inside
= tcExtendTyVarEnvFromSig sig thing_inside
tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig sig_inst thing_inside
| TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
= tcExtendNameTyVarEnv wcs $
tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $
thing_inside
tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs infos thing_inside
= tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
| MBI { mbi_mono_id = mono_id } <- infos ]
thing_inside
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
data GeneralisationPlan
= NoGen
| InferGen
Bool
| CheckGen (LHsBind GhcRn) TcIdSigInfo
instance Outputable GeneralisationPlan where
ppr NoGen = text "NoGen"
ppr (InferGen b) = text "InferGen" <+> ppr b
ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
decideGeneralisationPlan
:: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
-> GeneralisationPlan
decideGeneralisationPlan dflags lbinds closed sig_fn
| has_partial_sigs = InferGen (and partial_sig_mrs)
| Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
| do_not_generalise closed = NoGen
| otherwise = InferGen mono_restriction
where
binds = map unLoc lbinds
partial_sig_mrs :: [Bool]
partial_sig_mrs
= [ null theta
| TcIdSig (PartialSig { psig_hs_ty = hs_ty })
<- mapMaybe sig_fn (collectHsBindListBinders lbinds)
, let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]
has_partial_sigs = not (null partial_sig_mrs)
mono_restriction = xopt LangExt.MonomorphismRestriction dflags
&& any restricted binds
do_not_generalise (IsGroupClosed _ True) = False
do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
one_funbind_with_sig
| [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
, Just (TcIdSig sig) <- sig_fn (unLoc v)
= Just (lbind, sig)
| otherwise
= Nothing
restricted (PatBind {}) = True
restricted (VarBind { var_id = v }) = no_sig v
restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
&& no_sig (unLoc v)
restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
restricted_match mg = matchGroupArity mg == 0
no_sig n = not (hasCompleteSig sig_fn n)
isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
isClosedBndrGroup type_env binds
= IsGroupClosed fv_env type_closed
where
type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
bindFvs (FunBind { fun_id = L _ f
, fun_ext = fvs })
= let open_fvs = get_open_fvs fvs
in [(f, open_fvs)]
bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
= let open_fvs = get_open_fvs fvs
in [(b, open_fvs) | b <- collectPatBinders pat]
bindFvs _
= []
get_open_fvs fvs = filterNameSet (not . is_closed) fvs
is_closed :: Name -> ClosedTypeId
is_closed name
| Just thing <- lookupNameEnv type_env name
= case thing of
AGlobal {} -> True
ATcId { tct_info = ClosedLet } -> True
_ -> False
| otherwise
= True
is_closed_type_id :: Name -> Bool
is_closed_type_id name
| Just thing <- lookupNameEnv type_env name
= case thing of
ATcId { tct_info = NonClosedLet _ cl } -> cl
ATcId { tct_info = NotLetBound } -> False
ATyVar {} -> False
_ -> pprPanic "is_closed_id" (ppr name)
| otherwise
= True
patMonoBindsCtxt :: (OutputableBndrId p, Outputable body)
=> LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)