Commit ffde2348 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot
Browse files

Do eager instantation in terms

This patch implements eager instantiation, a small but critical change
to the type inference engine, #17173.  The main change is this:

  When inferring types, always return an instantiated type
  (for now, deeply instantiated; in future shallowly instantiated)

There is more discussion in
https://www.tweag.io/posts/2020-04-02-lazy-eager-instantiation.html

There is quite a bit of refactoring in this patch:

* The ir_inst field of GHC.Tc.Utils.TcType.InferResultk
  has entirely gone.  So tcInferInst and tcInferNoInst have collapsed
  into tcInfer.

* Type inference of applications, via tcInferApp and
  tcInferAppHead, are substantially refactored, preparing
  the way for Quick Look impredicativity.

* New pure function GHC.Tc.Gen.Expr.collectHsArgs and applyHsArgs
  are beatifully dual.  We can see the zipper!

* GHC.Tc.Gen.Expr.tcArgs is now much nicer; no longer needs to return
  a wrapper

* In HsExpr, HsTypeApp now contains the the actual type argument,
  and is used in desugaring, rather than putting it in a mysterious
  wrapper.

* I struggled a bit with good error reporting in
  Unify.matchActualFunTysPart. It's a little bit simpler than before,
  but still not great.

Some smaller things

* Rename tcPolyExpr --> tcCheckExpr
         tcMonoExpr --> tcLExpr
* tcPatSig moves from GHC.Tc.Gen.HsType to GHC.Tc.Gen.Pat

Metric Decrease:
    T9961

Reduction of 1.6% in comiler allocation on T9961, I think.
parent 34a45ee6
Pipeline #18461 passed with stages
in 411 minutes and 56 seconds
......@@ -293,7 +293,9 @@ data HsExpr p
| HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
| HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application
| HsAppType (XAppTypeE p) -- After typechecking: the type argument
(LHsExpr p)
(LHsWcType (NoGhcTc p)) -- ^ Visible type application
--
-- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quantification
......@@ -599,7 +601,9 @@ type instance XLam (GhcPass _) = NoExtField
type instance XLamCase (GhcPass _) = NoExtField
type instance XApp (GhcPass _) = NoExtField
type instance XAppTypeE (GhcPass _) = NoExtField
type instance XAppTypeE GhcPs = NoExtField
type instance XAppTypeE GhcRn = NoExtField
type instance XAppTypeE GhcTc = Type
type instance XOpApp GhcPs = NoExtField
type instance XOpApp GhcRn = Fixity
......@@ -1214,8 +1218,12 @@ parenthesizeHsExpr p le@(L loc e)
| hsExprNeedsParens p e = L loc (HsPar noExtField le)
| otherwise = le
stripParensHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensHsExpr (L _ (HsPar _ e)) = stripParensHsExpr e
stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e
stripParensLHsExpr e = e
stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e
stripParensHsExpr e = e
isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool
......@@ -2566,7 +2574,7 @@ instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where
pprPendingSplice :: (OutputableBndrId p)
=> SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensHsExpr e))
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))
pprSpliceDecl :: (OutputableBndrId p)
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
......
......@@ -187,8 +187,7 @@ mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)
mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
=> LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
where
t_body = hswc_body t
......
......@@ -316,9 +316,9 @@ dsExpr e@(HsApp _ fun arg)
; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
dsExpr (HsAppType _ e _)
-- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e
dsExpr (HsAppType ty e _)
= do { e' <- dsLExpr e
; return (App e' (Type ty)) }
{-
Note [Desugaring vars]
......
......@@ -48,7 +48,7 @@ import GHC.Driver.Hooks
import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
, decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcPolyExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Splice
( runMetaD
, runMetaE
......@@ -324,7 +324,7 @@ runRnSplice flavour run_meta ppr_res splice
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcPolyExpr the_expr meta_exp_ty)
(tcCheckExpr the_expr meta_exp_ty)
-- Run the expression
; mod_finalizers_ref <- newTcRef []
......@@ -760,7 +760,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
spliceDebugDoc loc
= let code = case mb_src of
Nothing -> ending
Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending
Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending
ending = [ text "======>", nest 2 gen ]
in hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
2 (sep code)
......
......@@ -14,7 +14,7 @@ module GHC.Tc.Gen.Arrow ( tcProc ) where
import GhcPrelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcLExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcCheckExpr )
import GHC.Hs
import GHC.Tc.Gen.Match
......@@ -91,7 +91,7 @@ tcProc pat cmd exp_ty
; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $
; (pat', cmd') <- tcCheckPat ProcExpr pat arg_ty $
tcCmdTop cmd_env cmd (unitTy, res_ty)
; let res_co = mkTcTransCo co
(mkTcAppCo co1 (mkTcNomReflCo res_ty))
......@@ -160,7 +160,7 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
; tcCmd env body (stk, res_ty') }
tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
= do { pred' <- tcLExpr pred (mkCheckExpType boolTy)
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')
......@@ -178,7 +178,7 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn
; (pred', fun')
<- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
(mkCheckExpType r_ty) $ \ _ ->
tcMonoExpr pred (mkCheckExpType pred_ty)
tcLExpr pred (mkCheckExpType pred_ty)
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
......@@ -205,9 +205,9 @@ tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newOpenFlexiTyVarTy
; let fun_ty = mkCmdArrTy env arg_ty res_ty
; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))
; fun' <- select_arrow_scope (tcLExpr fun (mkCheckExpType fun_ty))
; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
; arg' <- tcLExpr arg (mkCheckExpType arg_ty)
; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
where
......@@ -232,7 +232,7 @@ tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newOpenFlexiTyVarTy
; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
; arg' <- tcLExpr arg (mkCheckExpType arg_ty)
; return (HsCmdApp x fun' arg') }
-------------------------------------------
......@@ -309,7 +309,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
; let e_ty = mkInvForAllTy alphaTyVar $
mkVisFunTys cmd_tys $
mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
; expr' <- tcPolyExpr expr e_ty
; expr' <- tcCheckExpr expr e_ty
; return (HsCmdArrForm x expr' f fixity cmd_args') }
where
......@@ -366,7 +366,7 @@ tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_arr_rhs env rhs
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (mkTcBindStmt pat' rhs', thing) }
......
......@@ -23,7 +23,7 @@ where
import GhcPrelude
import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcMonoExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcLExpr )
import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import GHC.Core (Tickish (..))
import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
......@@ -354,7 +354,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
= do { ty <- newOpenFlexiTyVarTy
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcMonoExpr expr (mkCheckExpType ty)
; expr' <- tcLExpr expr (mkCheckExpType 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"
......@@ -1263,9 +1263,7 @@ tcMonoBinds is_rec sig_fn no_gen
-- We want to infer a higher-rank type for f
setSrcSpan b_loc $
do { ((co_fn, matches'), rhs_ty)
<- tcInferInst $ \ exp_ty ->
-- tcInferInst: see GHC.Tc.Utils.Unify,
-- Note [Deep instantiation of InferResult] in GHC.Tc.Utils.Unify
<- tcInfer $ \ exp_ty ->
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-- We extend the error context even for a non-recursive
-- function so that in type error messages we show the
......@@ -1362,7 +1360,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
-- See Note [Existentials in pattern bindings]
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (patMonoBindsCtxt pat grhss) $
tcInferNoInst $ \ exp_ty ->
tcInfer $ \ exp_ty ->
tcLetPat inst_sig_fun no_gen pat exp_ty $
mapM lookup_info nosig_names
......
This diff is collapsed.
......@@ -6,23 +6,16 @@ import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.Origin ( CtOrigin )
import GHC.Hs.Extension ( GhcRn, GhcTcId )
tcPolyExpr ::
LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTcId)
tcMonoExpr, tcMonoExprNC ::
LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTcId)
tcInferSigma ::
LHsExpr GhcRn
-> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho, tcInferRhoNC ::
LHsExpr GhcRn
-> TcM (LHsExpr GhcTcId, TcRhoType)
tcCheckExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcLExpr, tcLExprNC
:: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcInferRho, tcInferRhoNC
:: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcRhoType)
tcInferSigma :: LHsExpr GhcRn-> TcM (LHsExpr GhcTcId, TcSigmaType)
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
......
......@@ -388,7 +388,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe
= addErrCtxt (foreignDeclCtxt fo) $ do
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
rhs <- tcPolyExpr (nlHsVar nm) sig_ty
rhs <- tcCheckExpr (nlHsVar nm) sig_ty
(norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
......
......@@ -60,7 +60,7 @@ module GHC.Tc.Gen.HsType (
checkClassKindSig,
-- Pattern type signatures
tcHsPatSigType, tcPatSig,
tcHsPatSigType,
-- Error messages
funAppCtxt, addTyConFlavCtxt
......@@ -75,7 +75,6 @@ import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Core.Predicate
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Validity
......@@ -3390,58 +3389,6 @@ tcHsPatSigType ctxt sig_ty
-- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
; return (name, tv) }
tcPatSig :: Bool -- True <=> pattern binding
-> LHsSigWcType GhcRn
-> ExpSigmaType
-> TcM (TcType, -- The type to use for "inside" the signature
[(Name,TcTyVar)], -- The new bit of type environment, binding
-- the scoped type variables
[(Name,TcTyVar)], -- The wildcards
HsWrapper) -- Coercion due to unification with actual ty
-- Of shape: res_ty ~ sig_ty
tcPatSig in_pat_bind sig res_ty
= do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
-- sig_tvs are the type variables free in 'sig',
-- and not already in scope. These are the ones
-- that should be brought into scope
; if null sig_tvs then do {
-- Just do the subsumption check and return
wrap <- addErrCtxtM (mk_msg sig_ty) $
tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
; return (sig_ty, [], sig_wcs, wrap)
} else do
-- Type signature binds at least one scoped type variable
-- A pattern binding cannot bind scoped type variables
-- It is more convenient to make the test here
-- than in the renamer
{ when in_pat_bind (addErr (patBindSigErr sig_tvs))
-- Now do a subsumption check of the pattern signature against res_ty
; wrap <- addErrCtxtM (mk_msg sig_ty) $
tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
-- Phew!
; return (sig_ty, sig_tvs, sig_wcs, wrap)
} }
where
mk_msg sig_ty tidy_env
= do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
; res_ty <- readExpType res_ty -- should be filled in by now
; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
; let msg = vcat [ hang (text "When checking that the pattern signature:")
4 (ppr sig_ty)
, nest 2 (hang (text "fits the type of its context:")
2 (ppr res_ty)) ]
; return (tidy_env, msg) }
patBindSigErr :: [(Name,TcTyVar)] -> SDoc
patBindSigErr sig_tvs
= hang (text "You cannot bind scoped type variable" <> plural sig_tvs
<+> pprQuotedList (map fst sig_tvs))
2 (text "in a pattern binding signature")
{- Note [Pattern signature binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [Type variables in the type environment] in GHC.Tc.Utils.
......
......@@ -37,7 +37,8 @@ where
import GhcPrelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho
, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
, tcCheckId, tcLExpr, tcLExprNC, tcExpr
, tcCheckExpr )
import GHC.Types.Basic (LexicalFixity(..))
import GHC.Hs
......@@ -331,7 +332,7 @@ tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
tcBody body res_ty
= do { traceTc "tcBody" (ppr res_ty)
; tcMonoExpr body res_ty
; tcLExpr body res_ty
}
{-
......@@ -411,15 +412,15 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
tcGuardStmt :: TcExprStmtChecker
tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
= do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
= do { guard' <- tcLExpr guard (mkCheckExpType boolTy)
; thing <- thing_inside res_ty
; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- Stmt has a context already
; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat (mkCheckExpType rhs_ty) $
; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
pat rhs_ty $
thing_inside res_ty
; return (mkTcBindStmt pat' rhs', thing) }
......@@ -444,21 +445,21 @@ tcLcStmt :: TyCon -- The list type constructor ([])
-> TcExprStmtChecker
tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
= do { body' <- tcMonoExprNC body elt_ty
= do { body' <- tcLExprNC body elt_ty
; thing <- thing_inside (panic "tcLcStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
-- A generator, pat <- rhs
tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
; rhs' <- tcLExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
thing_inside elt_ty
; return (mkTcBindStmt pat' rhs', thing) }
-- A boolean guard
tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy)
= do { rhs' <- tcLExpr rhs (mkCheckExpType boolTy)
; thing <- thing_inside elt_ty
; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
......@@ -516,7 +517,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
by_arrow $
poly_arg_ty `mkVisFunTy` poly_res_ty
; using' <- tcPolyExpr using using_poly_ty
; using' <- tcCheckExpr using using_poly_ty
; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
-- 'stmts' returns a result of type (m1_ty tuple_ty),
......@@ -558,7 +559,7 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
= do { (body', return_op')
<- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
\ [a_ty] ->
tcMonoExprNC body (mkCheckExpType a_ty)
tcLExprNC body (mkCheckExpType a_ty)
; thing <- thing_inside (panic "tcMcStmt: thing_inside")
; return (LastStmt x body' noret return_op', thing) }
......@@ -574,9 +575,8 @@ tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
<- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
[SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
(mkCheckExpType pat_ty) $
do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs', pat', thing, new_res_ty) }
......@@ -607,7 +607,7 @@ tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
<- tcSyntaxOp MCompOrigin guard_op [SynAny]
(mkCheckExpType rhs_ty) $
\ [test_ty] ->
tcMonoExpr rhs (mkCheckExpType test_ty)
tcLExpr rhs (mkCheckExpType test_ty)
; thing <- thing_inside (mkCheckExpType new_res_ty)
; return (thing, rhs', rhs_ty, guard_op') }
; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
......@@ -667,7 +667,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
(mkCheckExpType using_arg_ty) $ \res_ty' -> do
{ by' <- case by of
Nothing -> return Nothing
Just e -> do { e' <- tcMonoExpr e
Just e -> do { e' <- tcLExpr e
(mkCheckExpType by_e_ty)
; return (Just e') }
......@@ -693,7 +693,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
--------------- Typecheck the 'fmap' function -------------
; fmap_op' <- case form of
ThenForm -> return noExpr
_ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
_ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $
mkInvForAllTy alphaTyVar $
mkInvForAllTy betaTyVar $
(alphaTy `mkVisFunTy` betaTy)
......@@ -703,7 +703,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
--------------- Typecheck the 'using' function -------------
-- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
; using' <- tcPolyExpr using using_poly_ty
; using' <- tcCheckExpr using using_poly_ty
; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
--------------- Building the bindersMap ----------------
......@@ -765,7 +765,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
(m_ty `mkAppTy` betaTy)
`mkVisFunTy`
(m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
; mzip_op' <- unLoc `fmap` tcCheckExpr (noLoc mzip_op) mzip_ty
-- type dummies since we don't know all binder types yet
; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
......@@ -827,7 +827,7 @@ tcMcStmt _ stmt _ _
tcDoStmt :: TcExprStmtChecker
tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
= do { body' <- tcMonoExprNC body res_ty
= do { body' <- tcLExprNC body res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
......@@ -840,9 +840,8 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
((rhs', pat', new_res_ty, thing), bind_op')
<- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
\ [rhs_ty, pat_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
(mkCheckExpType pat_ty) $
do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty)
; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
thing_inside (mkCheckExpType new_res_ty)
; return (rhs', pat', new_res_ty, thing) }
......@@ -874,7 +873,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
; ((rhs', rhs_ty, thing), then_op')
<- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
\ [rhs_ty, new_res_ty] ->
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty)
; thing <- thing_inside (mkCheckExpType new_res_ty)
; return (rhs', rhs_ty, thing) }
; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
......@@ -890,7 +889,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; tcExtendIdEnv tup_ids $ do
{ ((stmts', (ret_op', tup_rets)), stmts_ty)
<- tcInferInst $ \ exp_ty ->
<- tcInfer $ \ exp_ty ->
tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names
(map mkCheckExpType tup_elt_tys)
......@@ -902,7 +901,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; return (ret_op', tup_rets) }
; ((_, mfix_op'), mfix_res_ty)
<- tcInferInst $ \ exp_ty ->
<- tcInfer $ \ exp_ty ->
tcSyntaxOp DoOrigin mfix_op
[synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $
\ _ -> return ()
......@@ -968,7 +967,7 @@ When typechecking
do { bar; ... } :: IO ()
we want to typecheck 'bar' in the knowledge that it should be an IO thing,
pushing info from the context into the RHS. To do this, we check the
rebindable syntax first, and push that information into (tcMonoExprNC rhs).
rebindable syntax first, and push that information into (tcLExprNC rhs).
Otherwise the error shows up when checking the rebindable syntax, and
the expected/inferred stuff is back to front (see #3613).
......@@ -1000,7 +999,7 @@ tcApplicativeStmts
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
; let arity = length pairs
; ts <- replicateM (arity-1) $ newInferExpTypeInst
; ts <- replicateM (arity-1) $ newInferExpType
; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
; let fun_ty = mkVisFunTys pat_tys body_ty
......@@ -1044,8 +1043,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
}, pat_ty, exp_ty)
= setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $
do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
do { rhs' <- tcLExprNC rhs (mkCheckExpType exp_ty)
; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
return ()
; fail_op' <- fmap join . forM fail_op $ \fail ->
tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
......@@ -1061,8 +1060,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { (stmts', (ret',pat')) <-
tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
{ L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
{ ret' <- tcExpr ret res_ty
; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $
return ()
; return (ret', pat')
}
......
......@@ -16,8 +16,7 @@ module GHC.Tc.Gen.Pat
( tcLetPat
, newLetBndr
, LetBndrSpec(..)
, tcPat
, tcPat_O
, tcCheckPat, tcCheckPat_O, tcInferPat
, tcPats
, addDataConStupidTheta
, badFieldCon
......@@ -63,6 +62,7 @@ import Util
import Outputable
import qualified GHC.LanguageExtensions as LangExt
import Control.Arrow ( second )
import Control.Monad ( when )
import ListSetOps ( getNth )
{-
......@@ -112,20 +112,29 @@ tcPats ctxt pats pat_tys thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
tcPat :: HsMatchContext GhcRn
-> LPat GhcRn -> ExpSigmaType
-> TcM a -- Checker for body
-> TcM (LPat GhcTcId, a)
tcPat ctxt = tcPat_O ctxt PatOrigin
tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTcId, a), TcSigmaType)
tcInferPat ctxt pat thing_inside
= tcInfer $ \ exp_ty ->
tc_lpat pat exp_ty penv thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
tcCheckPat :: HsMatchContext GhcRn
-> LPat GhcRn -> TcSigmaType
-> TcM a -- Checker for body
-> TcM (LPat GhcTcId, a)
tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
-- | A variant of 'tcPat' that takes a custom origin
tcPat_O :: HsMatchContext GhcRn
-> CtOrigin -- ^ origin to use if the type needs inst'ing