summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs40
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs22
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs-boot4
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs10
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs3
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
7 files changed, 54 insertions, 29 deletions
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 4caa73e625..207f83cb51 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -275,7 +275,7 @@ tc_cmd env
; return (mkHsCmdWrap (mkWpCastN co) cmd') }
where
n_pats = length pats
- match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr?
+ match_ctxt = LambdaExpr -- Maybe KappaExpr?
pg_ctxt = PatGuard match_ctxt
tc_grhss (GRHSs x grhss binds) stk_ty res_ty
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 368248dc28..e540e3db91 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -622,7 +622,7 @@ tcPolyCheck prag_fn
-- See Note [Relevant bindings and the binder stack]
setSrcSpanA bind_loc $
- tcMatchesFun (L nm_loc mono_name) matches
+ tcMatchesFun (L nm_loc mono_id) matches
(mkCheckExpType rho_ty)
-- We make a funny AbsBinds, abstracting over nothing,
@@ -1189,15 +1189,19 @@ tcMonoBinds is_rec sig_fn no_gen
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
= setSrcSpanA b_loc $
- do { ((co_fn, matches'), rhs_ty)
- <- 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
- -- type of the thing whose rhs we are type checking
- tcMatchesFun (L nm_loc name) matches exp_ty
-
- ; mono_id <- newLetBndr no_gen name Many rhs_ty
+ do { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->
+ -- See Note [fixM for rhs_ty in tcMonoBinds]
+ do { mono_id <- newLetBndr no_gen name Many rhs_ty
+ ; (matches', rhs_ty')
+ <- 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
+ -- type of the thing whose rhs we are type checking
+ tcMatchesFun (L nm_loc mono_id) matches exp_ty
+ ; return (matches', mono_id, rhs_ty')
+ }
+
; return (unitBag $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches',
@@ -1309,6 +1313,20 @@ Here we want to push p's signature inwards, i.e. /checking/, to
correctly elaborate 'id'. But we want to /infer/ q's higher rank
type. There seems to be no way to do this. So currently we only
switch to inference when we have no signature for any of the binders.
+
+Note [fixM for rhs_ty in tcMonoBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to create mono_id we need rhs_ty but we don't have it yet,
+we only get it from tcMatchesFun later (which needs mono_id to put
+into HsMatchContext for pretty printing). To solve this, create
+a thunk of rhs_ty with fixM that we fill in later.
+
+This is fine only because neither newLetBndr or tcMatchesFun look
+at the varType field of the Id. tcMatchesFun only looks at idName
+of mono_id.
+
+Also see #20415 for the bigger picture of why tcMatchesFun needs
+mono_id in the first place.
-}
@@ -1436,7 +1454,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))
+ ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)
matches (mkCheckExpType $ idType mono_id)
; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
, fun_matches = matches'
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d1bca5d663..c8eb8fd233 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -91,12 +91,12 @@ is used in error messages. It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.
-}
-tcMatchesFun :: LocatedN Name
+tcMatchesFun :: LocatedN Id -- MatchContext Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType -- Expected type of function
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-- Returns type of body
-tcMatchesFun fn@(L _ fun_name) matches exp_ty
+tcMatchesFun fun_id matches exp_ty
= do { -- Check that they all have the same no of arguments
-- Location is in the monad, set the caller so that
-- any inter-equation error messages get some vaguely
@@ -118,12 +118,18 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
-- a multiplicity argument, and scale accordingly.
tcMatches match_ctxt pat_tys rhs_ty matches }
where
+ fun_name = idName (unLoc fun_id)
arity = matchGroupArity matches
herald = text "The equation(s) for"
<+> quotes (ppr fun_name) <+> text "have"
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
-- But that's wrong for f :: Int -> forall a. blah
- what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+ what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
+ -- Careful: this fun_id could be an unfilled
+ -- thunk from fixM in tcMonoBinds, so we're
+ -- not allowed to look at it, except for
+ -- idName.
+ -- See Note [fixM for rhs_ty in tcMonoBinds]
match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
@@ -186,7 +192,7 @@ tcGRHSsPat grhss res_ty
********************************************************************* -}
data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
- = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is
+ = MC { mc_what :: HsMatchContext GhcTc, -- What kind of thing this is
mc_body :: LocatedA (body GhcRn) -- Type checker for a body of
-- an alternative
-> ExpRhoType
@@ -345,13 +351,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
- = forall thing. HsStmtContext GhcRn
+ = forall thing. HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type -- Result type for comprehension
-> (rho_type -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
-tcStmts :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -361,7 +367,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -999,7 +1005,7 @@ join :: tn -> res_ty
-}
tcApplicativeStmts
- :: HsStmtContext GhcRn
+ :: HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
index 9f6b6bf239..dee8e0721e 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ b/compiler/GHC/Tc/Gen/Match.hs-boot
@@ -1,17 +1,17 @@
module GHC.Tc.Gen.Match where
import GHC.Hs ( GRHSs, MatchGroup, LHsExpr )
import GHC.Tc.Types.Evidence ( HsWrapper )
-import GHC.Types.Name ( Name )
import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType )
import GHC.Tc.Types ( TcM )
import GHC.Hs.Extension ( GhcRn, GhcTc )
import GHC.Parser.Annotation ( LocatedN )
+import GHC.Types.Id (Id)
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-tcMatchesFun :: LocatedN Name
+tcMatchesFun :: LocatedN Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 10c862f8f6..82d707dd76 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -97,7 +97,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
; tc_lpat pat_ty penv pat thing_inside }
-----------------
-tcPats :: HsMatchContext GhcRn
+tcPats :: HsMatchContext GhcTc
-> [LPat GhcRn] -- Patterns,
-> [Scaled ExpSigmaType] -- and their types
-> TcM a -- and the checker for the body
@@ -119,7 +119,7 @@ tcPats ctxt pats pat_tys thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
+tcInferPat :: HsMatchContext GhcTc -> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaType)
tcInferPat ctxt pat thing_inside
@@ -128,14 +128,14 @@ tcInferPat ctxt pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcCheckPat :: HsMatchContext GhcRn
+tcCheckPat :: HsMatchContext GhcTc
-> LPat GhcRn -> Scaled TcSigmaType
-> TcM a -- Checker for body
-> TcM (LPat GhcTc, a)
tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
-- | A variant of 'tcPat' that takes a custom origin
-tcCheckPat_O :: HsMatchContext GhcRn
+tcCheckPat_O :: HsMatchContext GhcTc
-> CtOrigin -- ^ origin to use if the type needs inst'ing
-> LPat GhcRn -> Scaled TcSigmaType
-> TcM a -- Checker for body
@@ -162,7 +162,7 @@ data PatEnv
data PatCtxt
= LamPat -- Used for lambdas, case etc
- (HsMatchContext GhcRn)
+ (HsMatchContext GhcTc)
| LetPat -- Used only for let(rec) pattern bindings
-- See Note [Typing patterns in pattern bindings]
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index fa4cd8fecf..c62ec59e1c 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -781,6 +781,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty
matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
matcher_id = mkExportedVanillaId matcher_name matcher_sigma
+ patsyn_id = mkExportedVanillaId name matcher_sigma
-- See Note [Exported LocalIds] in GHC.Types.Id
inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
@@ -808,7 +809,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty
, mg_origin = Generated
}
- match = mkMatch (mkPrefixFunRhs (L loc name)) []
+ match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(EmptyLocalBinds noExtField)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index e66a83f5bb..8c37480297 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -220,7 +220,7 @@ data SkolemInfo
| FamInstSkol -- Bound at a family instance decl
| PatSkol -- An existential type variable bound by a pattern for
ConLike -- a data constructor with an existential type.
- (HsMatchContext GhcRn)
+ (HsMatchContext GhcTc)
-- e.g. data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
View Lorry Controller Status