module GHC.Tc.Gen.Head
( HsExprArg(..), EValArg(..), TcPass(..)
, AppCtxt(..), appCtxtLoc, insideExpansion
, splitHsApps, rebuildHsApps
, addArgWrap, isHsValArg
, countLeadingValArgs, isVisibleArg, pprHsExprArgTc
, countVisAndInvisValArgs, countHsWrapperInvisArgs
, tcInferAppHead, tcInferAppHead_maybe
, tcInferId, tcCheckId
, obviousSig
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
, addExprCtxt, addFunResCtxt ) where
import GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( unitUE )
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
import GHC.Unit.Module ( getModule )
import GHC.Tc.Errors.Types
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.PatSyn( PatSyn )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
import Data.Function
import GHC.Prelude
data TcPass = TcpRn
| TcpInst
| TcpTc
data HsExprArg (p :: TcPass)
=
EValArg { eva_ctxt :: AppCtxt
, eva_arg :: EValArg p
, eva_arg_ty :: !(XEVAType p) }
| ETypeArg { eva_ctxt :: AppCtxt
, eva_hs_ty :: LHsWcType GhcRn
, eva_ty :: !(XETAType p) }
| EPrag AppCtxt
(HsPragE (GhcPass (XPass p)))
| EWrap EWrap
data EWrap = EPar AppCtxt
| EExpand (HsExpr GhcRn)
| EHsWrap HsWrapper
data EValArg (p :: TcPass) where
ValArg :: LHsExpr (GhcPass (XPass p))
-> EValArg p
ValArgQL :: { va_expr :: LHsExpr GhcRn
, va_fun :: (HsExpr GhcTc, AppCtxt)
, va_args :: [HsExprArg 'TcpInst]
, va_ty :: TcRhoType }
-> EValArg 'TcpInst
data AppCtxt
= VAExpansion
(HsExpr GhcRn)
SrcSpan
| VACall
(HsExpr GhcRn) Int
SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion _ l) = l
appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
insideExpansion (VACall {}) = False
instance Outputable AppCtxt where
ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
type family XPass p where
XPass 'TcpRn = 'Renamed
XPass 'TcpInst = 'Renamed
XPass 'TcpTc = 'Typechecked
type family XETAType p where
XETAType 'TcpRn = NoExtField
XETAType _ = Type
type family XEVAType p where
XEVAType 'TcpRn = NoExtField
XEVAType _ = Scaled Type
mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt
, eva_arg_ty = noExtField }
mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty
, eva_ty = noExtField }
addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
addArgWrap wrap args
| isIdHsWrapper wrap = args
| otherwise = EWrap (EHsWrap wrap) : args
splitHsApps :: HsExpr GhcRn
-> ( (HsExpr GhcRn, AppCtxt)
, [HsExprArg 'TcpRn])
splitHsApps e = go e (top_ctxt 0 e) []
where
top_ctxt n (HsPar _ _ fun _) = top_lctxt n fun
top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args)
go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args)
go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args)
go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
go (XExpr (HsExpanded orig fun)) ctxt args
= go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)
go e@(OpApp _ arg1 (L l op) arg2) _ args
= ( (op, VACall op 0 (locA l))
, mkEValArg (VACall op 1 generatedSrcSpan) arg1
: mkEValArg (VACall op 2 generatedSrcSpan) arg2
: EWrap (EExpand e)
: args )
go e ctxt args = ((e,ctxt), args)
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set l (VACall f n _) = VACall f n (locA l)
set _ ctxt@(VAExpansion {}) = ctxt
dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
dec l (VACall f n _) = VACall f (n1) (locA l)
dec _ ctxt@(VAExpansion {}) = ctxt
rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
rebuildHsApps fun _ [] = fun
rebuildHsApps fun ctxt (arg : args)
= case arg of
EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }
-> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args
ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' }
-> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args
EPrag ctxt' p
-> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args
EWrap (EPar ctxt')
-> rebuildHsApps (gHsPar lfun) ctxt' args
EWrap (EExpand orig)
-> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
EWrap (EHsWrap wrap)
-> rebuildHsApps (mkHsWrap wrap fun) ctxt args
where
lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun
isHsValArg :: HsExprArg id -> Bool
isHsValArg (EValArg {}) = True
isHsValArg _ = False
countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs [] = 0
countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args
countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args
countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args
countLeadingValArgs (ETypeArg {} : _) = 0
isValArg :: HsExprArg id -> Bool
isValArg (EValArg {}) = True
isValArg _ = False
isVisibleArg :: HsExprArg id -> Bool
isVisibleArg (EValArg {}) = True
isVisibleArg (ETypeArg {}) = True
isVisibleArg _ = False
countVisAndInvisValArgs :: [HsExprArg id] -> Arity
countVisAndInvisValArgs [] = 0
countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args
countVisAndInvisValArgs (EWrap wrap : args) =
case wrap of { EHsWrap hsWrap -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args
; EPar {} -> countVisAndInvisValArgs args
; EExpand {} -> countVisAndInvisValArgs args }
countVisAndInvisValArgs (EPrag {} : args) = countVisAndInvisValArgs args
countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args
countHsWrapperInvisArgs :: HsWrapper -> Arity
countHsWrapperInvisArgs = go
where
go WpHole = 0
go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2
go fun@(WpFun {}) = nope fun
go (WpCast {}) = 0
go evLam@(WpEvLam {}) = nope evLam
go (WpEvApp _) = 1
go tyLam@(WpTyLam {}) = nope tyLam
go (WpTyApp _) = 0
go (WpLet _) = 0
go (WpMultCoercion {}) = 0
nope x = pprPanic "countHsWrapperInvisApps" (ppr x)
instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg
ppr (EPrag _ p) = text "EPrag" <+> ppr p
ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
ppr (EWrap wrap) = ppr wrap
instance Outputable EWrap where
ppr (EPar _) = text "EPar"
ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
ppr (EExpand orig) = text "EExpand" <+> ppr orig
instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
ppr (ValArg e) = ppr e
ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty})
= hang (text "ValArgQL" <+> ppr fun)
2 (vcat [ ppr args, text "va_ty:" <+> ppr ty ])
pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })
= text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
pprHsExprArgTc arg = ppr arg
tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (fun,ctxt) args
= setSrcSpan (appCtxtLoc ctxt) $
do { mb_tc_fun <- tcInferAppHead_maybe fun args
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
Nothing -> add_head_ctxt fun args $
tcInfer (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe fun args
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
HsRecSel _ f -> Just <$> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $
Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))
-> tcInferAppHead_maybe e args
_ -> return Nothing
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt fun args thing_inside
| null args = thing_inside
| otherwise = addExprCtxt fun thing_inside
tcInferRecSelId :: FieldOcc GhcRn
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId (FieldOcc sel_name lbl)
= do { sel_id <- tc_rec_sel_id
; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)
; return (expr, idType sel_id)
}
where
occ :: OccName
occ = rdrNameOcc (unLoc lbl)
tc_rec_sel_id :: TcM TcId
tc_rec_sel_id
= do { thing <- tcLookup sel_name
; case thing of
ATcId { tct_id = id }
-> do { check_naughty occ id
; check_local_id id
; return id }
AGlobal (AnId id)
-> do { check_naughty occ id
; return id }
_ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
ppr thing <+> text "used where a value identifier was expected" }
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig _ _ ty) = Just ty
obviousSig (HsPar _ _ p _) = obviousSig (unLoc p)
obviousSig (HsPragE _ _ p) = obviousSig (unLoc p)
obviousSig _ = Nothing
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf fam_inst_envs ty0
= case tcSplitTyConApp_maybe ty of
Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
Nothing -> Nothing
where
(_, _, ty) = tcSplitSigmaTy ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents is_selector rdr
= do { env <- getGlobalRdrEnv
; let all_gres = lookupGRE_RdrName' rdr env
; let gres | is_selector = filter isFieldSelectorGRE all_gres
| otherwise = filter isRecFldGRE all_gres
; mapM lookupParent gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent gre = do { id <- tcLookupId (greMangledName gre)
; case recordSelectorTyCon_maybe id of
Just rstc -> return (rstc, gre)
Nothing -> failWithTc (notSelector (greMangledName gre)) }
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType p rdr
= mkTcRnNotInScope rdr $
UnknownSubordinate (text "field of type" <+> quotes (ppr p))
notSelector :: Name -> TcRnMessage
notSelector field
= TcRnUnknownMessage $ mkPlainError noHints $
hsep [quotes (ppr field), text "is not a record selector"]
naughtyRecordSel :: OccName -> TcRnMessage
naughtyRecordSel lbl
= TcRnUnknownMessage $ mkPlainError noHints $
text "Cannot use record selector" <+> quotes (ppr lbl) <+>
text "as a function due to escaped type variables" $$
text "Probable fix: use pattern-matching syntax instead"
tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig expr hs_ty
= do { sig_info <- checkNoErrs $
tcUserTypeSig loc hs_ty Nothing
; (expr', poly_ty) <- tcExprSig ctxt expr sig_info
; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
where
loc = getLocA (dropWildCards hs_ty)
ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
= setSrcSpan loc $
do { let poly_ty = idType poly_id
; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->
tcCheckMonoExprNC expr rho_ty
; return (mkLHsWrap wrap expr', poly_ty) }
tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
= setSrcSpan loc $
do { (tclvl, wanted, (expr', sig_inst))
<- pushLevelAndCaptureConstraints $
do { sig_inst <- tcInstSig sig
; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $
tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $
tcCheckPolyExprNC expr (sig_inst_tau sig_inst)
; return (expr', sig_inst) }
; let tau = sig_inst_tau sig_inst
infer_mode | null (sig_inst_theta sig_inst)
, isNothing (sig_inst_wcx sig_inst)
= ApplyMR
| otherwise
= NoRestrictions
; ((qtvs, givens, ev_binds, _), residual)
<- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
; emitConstraints residual
; tau <- zonkTcType tau
; let inferred_theta = map evVarPred givens
tau_tvs = tyCoVarsOfType tau
; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta
tau_tvs qtvs (Just sig_inst)
; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau)
; wrap <- if inferred_sigma `eqType` my_sigma
then return idHsWrapper
else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma
; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
; let poly_wrap = wrap
<.> mkWpTyLams qtvs
<.> mkWpLams givens
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', my_sigma) }
tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit lit@(OverLit { ol_val = val
, ol_ext = OverLitRn { ol_rebindable = rebindable
, ol_from_fun = L loc from_name } })
=
do { hs_lit <- mkOverLit val
; from_id <- tcLookupId from_name
; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)
; let
thing = NameThing from_name
mb_thing = Just thing
herald = ExpectedFunTyArg thing (HsLit noAnn hs_lit)
; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing
(1, []) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
HsLit noAnn hs_lit
from_expr = mkHsWrap (wrap2 <.> wrap1) $
HsVar noExtField (L loc from_id)
witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable
, ol_witness = witness
, ol_type = res_ty } }
; return (HsOverLit noAnn lit', res_ty) }
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId name res_ty
= do { (expr, actual_res_ty) <- tcInferId name
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addFunResCtxt rn_fun [] actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
where
rn_fun = HsVar noExtField (noLocA name)
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId id_name
| id_name `hasKey` assertIdKey
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then tc_infer_id id_name
else tc_infer_assert id_name }
| otherwise
= do { (expr, ty) <- tc_infer_id id_name
; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
; return (expr, ty) }
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert assert_name
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
}
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id id_name
= do { thing <- tcLookup id_name
; case thing of
ATcId { tct_id = id }
-> do { check_local_id id
; return_id id }
AGlobal (AnId id) -> return_id id
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
(tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc
ATyVar name _ -> fail_tyvar name
_ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
ppr thing <+> text "used where a value identifier was expected" }
where
fail_tycon tc = do
gre <- getGlobalRdrEnv
let nm = tyConName tc
pprov = case lookupGRE_Name gre nm of
Just gre -> nest 2 (pprNameProvenance gre)
Nothing -> empty
fail_with_msg dataName nm pprov
fail_tyvar nm =
let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
in fail_with_msg varName nm pprov
fail_with_msg whatName nm pprov = do
(import_errs, hints) <- get_suggestions whatName
unit_state <- hsc_units <$> getTopEnv
let
hint_msg = vcat $ map ppr hints
import_err_msg = vcat $ map ppr import_errs
info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
msg = TcRnMessageWithInfo unit_state
$ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)
failWithTc msg
get_suggestions ns = do
let occ = mkOccNameFS ns (occNameFS (occName id_name))
dflags <- getDynFlags
rdr_env <- getGlobalRdrEnv
lcl_env <- getLocalRdrEnv
imp_info <- getImports
curr_mod <- getModule
hpt <- getHpt
return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env
lcl_env imp_info (mkRdrUnqual occ)
return_id id = return (HsVar noExtField (noLocA id), idType id)
check_local_id :: Id -> TcM ()
check_local_id id
= do { checkThLocalId id
; tcEmitBindingUsage $ unitUE (idName id) One }
check_naughty :: OccName -> TcId -> TcM ()
check_naughty lbl id
| isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
| otherwise = return ()
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon con
= do { let tvbs = dataConUserTyVarBinders con
tvs = binderVars tvbs
theta = dataConOtherTheta con
args = dataConOrigArgTys con
res = dataConOrigResTy con
stupid_theta = dataConStupidTheta con
; scaled_arg_tys <- mapM linear_to_poly args
; let full_theta = stupid_theta ++ theta
all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys
; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)
, mkInvisForAllTys tvbs $ mkPhiTy full_theta $
mkVisFunTys scaled_arg_tys res ) }
where
linear_to_poly :: Scaled Type -> TcM (Scaled Type)
linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy
; return (Scaled mul_var ty) }
linear_to_poly scaled_ty = return scaled_ty
tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn id_name ps
= case patSynBuilderOcc ps of
Just (expr,ty) -> return (expr,ty)
Nothing -> failWithTc (nonBidirectionalErr id_name)
nonBidirectionalErr :: Outputable name => name -> TcRnMessage
nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $
text "non-bidirectional pattern synonym"
<+> quotes (ppr name) <+> text "used in an expression"
checkThLocalId :: Id -> TcM ()
checkThLocalId id
= do { mb_local_use <- getStageAndBindLevel (idName id)
; case mb_local_use of
Just (top_lvl, bind_lvl, use_stage)
| thLevel use_stage > bind_lvl
-> checkCrossStageLifting top_lvl id use_stage
_ -> return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
| isTopLevel top_lvl
= when (isExternalName id_name) (keepAlive id_name)
| otherwise
=
do { let id_ty = idType id
; checkTc (isTauTy id_ty) (polySpliceErr id)
; lift <- if isStringTy id_ty then
do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName
; return (HsVar noExtField (noLocA sid)) }
else
setConstraintVar lie_var $
newMethodFromName (OccurrenceOf id_name)
GHC.Builtin.Names.TH.liftName
[getRuntimeRep id_ty, id_ty]
; addDetailedDiagnostic (TcRnImplicitLift id)
; ps <- readMutVar ps_var
; let pending_splice = PendingTcSplice id_name
(nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift))
(nlHsVar id))
; writeMutVar ps_var (pending_splice : ps)
; return () }
where
id_name = idName id
checkCrossStageLifting _ _ _ = return ()
polySpliceErr :: Id -> TcRnMessage
polySpliceErr id
= TcRnUnknownMessage $ mkPlainError noHints $
text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt fun args fun_res_ty env_ty thing_inside
= addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside
where
mk_msg
= do { mb_env_ty <- readExpType_maybe env_ty
; fun_res' <- zonkTcType fun_res_ty
; env' <- case mb_env_ty of
Just env_ty -> zonkTcType env_ty
Nothing ->
do { dumping <- doptM Opt_D_dump_tc_trace
; massert dumping
; newFlexiTyVarTy liftedTypeKind }
; let
(_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
(_, _, env_tau) = tcSplitNestedSigmaTys env'
(args_fun, res_fun) = tcSplitFunTys fun_tau
(args_env, res_env) = tcSplitFunTys env_tau
n_fun = length args_fun
n_env = length args_env
info |
n_fun > n_env
, not_fun res_env
= text "Probable cause:" <+> quotes (ppr fun)
<+> text "is applied to too few arguments"
|
n_fun < n_env
, not_fun res_fun
, (n_fun + count isValArg args) >= n_env
= text "Possible cause:" <+> quotes (ppr fun)
<+> text "is applied to too many arguments"
| otherwise
= Outputable.empty
; return info }
not_fun ty
= case tcSplitTyConApp_maybe ty of
Just (tc, _) -> isAlgTyCon tc
Nothing -> False
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))