{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
tcHsBootSigs, tcPolyCheck,
addTypecheckedBinds,
chooseInferredQuantifiers,
badBootDeclErr ) where
import GhcPrelude
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import CoreSyn (Tickish (..))
import CostCentre (mkUserCC, CCFlavour(DeclCC))
import DynFlags
import FastString
import HsSyn
import HscTypes( isHsBootOrSig )
import TcSigs
import TcRnMonad
import TcEnv
import TcUnify
import TcSimplify
import TcEvidence
import TcHsType
import TcPat
import TcMType
import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import TysPrim
import TysWiredIn( mkBoxedTupleTy )
import Id
import Var
import VarSet
import VarEnv( TidyEnv )
import Module
import Name
import NameSet
import NameEnv
import SrcLoc
import Bag
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
import Outputable
import PrelNames( ipClassName )
import TcValidity (checkValidType)
import UniqFM
import UniqSet
import qualified GHC.LanguageExtensions as LangExt
import ConLike
import Control.Monad
#include "HsVersions.h"
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds tcg_env binds
| isHsBootOrSig (tcg_src tcg_env) = tcg_env
| otherwise = tcg_env { tcg_binds = foldr unionBags
(tcg_binds tcg_env)
binds }
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 = 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) sigs
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
tcHsBootSigs binds sigs
= do { checkTc (null binds) badBootDeclErr
; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
f (dL->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 GhcTcId, 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 | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]
tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)
= do { ty <- newOpenFlexiTyVarTy
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcMonoExpr expr (mkCheckExpType ty)
; let d = toDict ipClass p ty `fmap` expr'
; return (ip_id, (IPBind noExt (Right ip_id) d)) }
tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds"
tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTcId)], 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 GhcTcId)], 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 GhcTcId)], 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)
; when hasPatSyn $ recursivePatSynErr binds
; (binds1, thing) <- go sccs
; return ([(Recursive, binds1)], thing) }
where
hasPatSyn = anyBag (isPatSyn . unLoc) binds
isPatSyn PatSynBind{} = True
isPatSyn _ = False
sccs :: [SCC (LHsBind GhcRn)]
sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, 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 (GhcPass p) =>
LHsBinds (GhcPass p) -> TcM a
recursivePatSynErr binds
= failWithTc $
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 (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
<+> pprLoc loc
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind GhcRn -> IsGroupClosed -> TcM thing
-> TcM (LHsBinds GhcTcId, thing)
tc_single _top_lvl sig_fn _prag_fn
(dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->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) | (dL->L _ bind, key) <- keyd_binds
, bndr <- collectHsBindBinders bind ]
tcPolyBinds :: TcSigFun -> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTcId, [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 GhcTcId, [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 forall_a_a
forall_a_a :: TcType
forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
tcPolyNoGen
:: RecFlag
-> TcPragEnv -> TcSigFun
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTcId, [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 GhcTcId, [TcId])
tcPolyCheck prag_fn
(CompleteSig { sig_bndr = poly_id
, sig_ctxt = ctxt
, sig_loc = sig_loc })
(dL->L loc (FunBind { fun_id = (dL->L nm_loc name)
, fun_matches = matches }))
= setSrcSpan sig_loc $
do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
; mono_name <- newNameAt (nameOccName name) nm_loc
; ev_vars <- newEvVars theta
; let mono_id = mkLocalId mono_name tau
skol_info = SigSkol ctxt (idType poly_id) tv_prs
skol_tvs = map snd tv_prs
; (ev_binds, (co_fn, matches'))
<- checkConstraints skol_info skol_tvs ev_vars $
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
tcExtendNameTyVarEnv tv_prs $
setSrcSpan loc $
tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)
; let prag_sigs = lookupPragEnv prag_fn name
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
; tick <- funBindTicks nm_loc mono_id mod prag_sigs
; let bind' = FunBind { fun_id = cL nm_loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, fun_ext = placeHolderNamesTc
, fun_tick = tick }
export = ABE { abe_ext = noExt
, abe_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }
abs_bind = cL loc $
AbsBinds { abs_ext = noExt
, abs_tvs = skol_tvs
, abs_ev_vars = ev_vars
, abs_ev_binds = [ev_binds]
, abs_exports = [export]
, abs_binds = unitBag (cL 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 | (dL->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 GhcTcId, [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 = cL loc $
AbsBinds { abs_ext = noExt
, 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) $
tcSubType_NC 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 = noExt
, 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 = mkForAllTys 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 (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
chooseInferredQuantifiers :: TcThetaType
-> TcTyVarSet
-> [TcTyVar]
-> Maybe TcIdSigInst
-> TcM ([TyVarBinder], 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 Inferred 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 { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs
; 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) ]
; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
; annotated_theta <- zonkTcTypes annotated_theta
; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
; let keep_me = free_tvs `unionVarSet` psig_qtvs
final_qtvs = [ mkTyVarBinder vis tv
| tv <- qtvs
, tv `elemVarSet` keep_me
, let vis | tv `elemVarSet` psig_qtvs = Specified
| otherwise = Inferred ]
; 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 GhcTcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
[ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)
, fun_matches = matches
, fun_ext = fvs })]
| NonRecursive <- is_rec
, Nothing <- sig_fn name
=
setSrcSpan b_loc $
do { ((co_fn, matches'), rhs_ty)
<- tcInferInst $ \ exp_ty ->
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
tcMatchesFun (cL nm_loc name) matches exp_ty
; mono_id <- newLetBndr no_gen name rhs_ty
; return (unitBag $ cL b_loc $
FunBind { fun_id = cL nm_loc mono_id,
fun_matches = matches', fun_ext = fvs,
fun_co_fn = 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 GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
TcSigmaType
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs sig_fn no_gen (FunBind { fun_id = (dL->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 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) $
tcInferNoInst $ \ exp_ty ->
tcLetPat inst_sig_fun no_gen pat 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 tau
tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)
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 (cL loc (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
; return ( FunBind { fun_id = cL loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, fun_ext = placeHolderNamesTc
, 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) $
tcGRHSsPat grhss pat_ty
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
, pat_ext = NPatBindTc placeHolderNamesTc 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 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 (_, dL->L _ theta, _) = splitLHsSigmaTy (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@(dL->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 = (dL->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 (GhcPass p), Outputable body)
=> LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)