diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Arrow.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 29 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 46 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs-boot | 4 |
4 files changed, 22 insertions, 59 deletions
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 65202cdeb2..0f06b5f9d7 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -172,7 +172,7 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty = addErrCtxt (cmdCtxt cmd) do { let match_ctxt = ArrowLamCaseAlt lc_variant - ; checkPatCounts (ArrowMatchCtxt match_ctxt) match + ; checkArgCounts (ArrowMatchCtxt match_ctxt) match ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index cf2cac142b..6441fe991a 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -624,7 +624,7 @@ tcPolyCheck prag_fn -- See Note [Relevant bindings and the binder stack] setSrcSpanA bind_loc $ - tcMatchesFun (L nm_loc mono_id) matches + tcMatchesFun (L nm_loc (idName mono_id)) matches (mkCheckExpType rho_ty) -- We make a funny AbsBinds, abstracting over nothing, @@ -1263,18 +1263,14 @@ 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'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) -> - -- See Note [fixM for rhs_ty in tcMonoBinds] - do { mono_id <- newLetBndr no_gen name ManyTy rhs_ty - ; (matches', rhs_ty') - <- tcInfer $ \ exp_ty -> + 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 mono_id) matches exp_ty - ; return (matches', mono_id, rhs_ty') - } + tcMatchesFun (L nm_loc name) matches exp_ty + ; mono_id <- newLetBndr no_gen name ManyTy rhs_ty' ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, @@ -1388,19 +1384,6 @@ 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. -} @@ -1528,7 +1511,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) mono_id) + ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName 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 7c331fb970..1d2b789261 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -31,7 +31,7 @@ module GHC.Tc.Gen.Match , tcBody , tcDoStmt , tcGuardStmt - , checkPatCounts + , checkArgCounts ) where @@ -93,12 +93,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 Id -- MatchContext Id +tcMatchesFun :: LocatedN Name -- MatchContext Id -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tcMatchesFun fun_id matches exp_ty +tcMatchesFun fun_name 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 @@ -106,9 +106,7 @@ tcMatchesFun fun_id matches exp_ty -- ann-grabbing, because we don't always have annotations in -- hand when we call tcMatchesFun... traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - -- We can't easily call checkPatCounts here because fun_id can be an - -- unfilled thunk - ; checkArgCounts fun_name matches + ; checkArgCounts what matches ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but @@ -122,17 +120,11 @@ tcMatchesFun fun_id 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 = ExpectedFunTyMatches (NameThing fun_name) matches + herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True -- But that's wrong for f :: Int -> forall a. blah - 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] + what = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness } match_ctxt = MC { mc_what = what, mc_body = tcBody } strictness | [L _ match] <- unLoc $ mg_alts matches @@ -164,7 +156,7 @@ tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty - = do { checkPatCounts (mc_what match_ctxt) match + = do { checkArgCounts (mc_what match_ctxt) match ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do -- checking argument counts since this is also used for \cases tcMatches match_ctxt pat_tys rhs_ty match } @@ -1136,28 +1128,16 @@ the variables they bind into scope, and typecheck the thing_inside. \subsection{Errors and contexts} * * ************************************************************************ - -@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. -} +-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same +-- number of args are used in each equation. checkArgCounts :: AnnoBody body - => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () -checkArgCounts = check_match_pats . EquationArgs - --- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same --- number of patterns are used in each alternative -checkPatCounts :: AnnoBody body - => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () -checkPatCounts = check_match_pats . PatternArgs - -check_match_pats :: AnnoBody body - => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () -check_match_pats _ (MG { mg_alts = L _ [] }) + => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM () +checkArgCounts _ (MG { mg_alts = L _ [] }) = return () -check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) }) +checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) | Just bad_matches <- mb_bad_matches = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext $ MatchArgMatches match1 bad_matches diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot index dee8e0721e..80790f2f9c 100644 --- a/compiler/GHC/Tc/Gen/Match.hs-boot +++ b/compiler/GHC/Tc/Gen/Match.hs-boot @@ -5,13 +5,13 @@ 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) +import GHC.Types.Name (Name) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Id +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) |