[Git][ghc/ghc][wip/sand-witch/lazy-skol] More improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Jan 6 00:18:33 UTC 2024
Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC
Commits:
ee179934 by Simon Peyton Jones at 2024-01-06T00:18:14+00:00
More improvements
- - - - -
10 changed files:
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Match.hs-boot
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/Language/Haskell/Syntax/Expr.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -49,7 +49,7 @@ module GHC.Core.TyCo.Rep (
mkFunTy, mkNakedFunTy,
mkVisFunTy, mkScaledFunTys,
mkInvisFunTy, mkInvisFunTys,
- tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys,
+ tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,
mkForAllTy, mkForAllTys, mkInvisForAllTys,
mkPiTy, mkPiTys,
mkVisFunTyMany, mkVisFunTysMany,
@@ -782,9 +782,10 @@ tcMkScaledFunTys :: [Scaled Type] -> Type -> Type
-- All visible args
-- Result type must be TypeLike
-- No mkFunTy assert checking; result kind may not be zonked
-tcMkScaledFunTys tys ty = foldr mk ty tys
- where
- mk (Scaled mult arg) res = tcMkVisFunTy mult arg res
+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys
+
+tcMkScaledFunTy :: Scaled Type -> Type -> Type
+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res
---------------
-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -263,8 +263,8 @@ tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty
LamSingle -> id -- Avoids clutter in the vanilla-lambda form
_ -> addErrCtxt (cmdCtxt cmd)) $
do { let match_ctxt = ArrowLamAlt lam_variant
- ; checkArgCounts (ArrowMatchCtxt match_ctxt) match
- ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty
+ ; arity <- checkArgCounts (ArrowMatchCtxt match_ctxt) match
+ ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty
; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }
-------------------------------------------
@@ -319,7 +319,7 @@ tcCmdMatches :: CmdEnv
-> CmdType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatches env scrut_ty matches (stk, res_ty)
- = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
+ = tcCaseMatches match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
where
match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt,
mc_body = mc_body }
@@ -328,15 +328,14 @@ tcCmdMatches env scrut_ty matches (stk, res_ty)
-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
tcCmdMatchLambda :: CmdEnv
- -> HsArrowMatchContext
+ -> HsArrowMatchContext -> Arity
-> MatchGroup GhcRn (LHsCmd GhcRn)
-> CmdType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
-tcCmdMatchLambda env
- ctxt
+tcCmdMatchLambda env ctxt arity
mg at MG { mg_alts = L l matches, mg_ext = origin }
(cmd_stk, res_ty)
- = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
+ = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs arity cmd_stk
; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys
; matches' <- forM matches $
@@ -348,9 +347,6 @@ tcCmdMatchLambda env
; return (mkWpCastN co, mg') }
where
- n_pats | isEmptyMatchGroup mg = 1 -- must be lambda-case
- | otherwise = matchGroupArity mg
-
-- Check the patterns, and the GRHSs inside
tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))
= do { (pats', grhss') <- setSrcSpanA mtch_loc $
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -23,7 +23,7 @@ where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr )
import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
@@ -627,12 +627,18 @@ tcPolyCheck prag_fn
, fun_matches = matches }))
= do { traceTc "tcPolyCheck" (ppr sig)
+ -- Make a new Name, whose SrcSpan is nm_loc. For a ClassOp
+ -- The original Name, in the FunBind{fun_id}, is bound in the
+ -- class declaration, whereas we want a Name bound right here.
+ -- We pass mono_name to tcFunBindMatches which in turn puts it in
+ -- the BinderStack, whence it shows up in "Relevant bindings.."
; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
+
; mult <- tcMultAnn (HsNoMultAnn noExtField)
; (wrap_gen, (wrap_res, matches'))
<- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty ->
setSrcSpanA bind_loc $
- tcMatchesFun ctxt mult matches invis_pat_tys rho_ty
+ tcFunBindMatches ctxt mono_name mult matches invis_pat_tys rho_ty
-- We make a funny AbsBinds, abstracting over nothing,
-- just so we have somewhere to put the SpecPrags.
@@ -1358,7 +1364,7 @@ tcMonoBinds is_rec sig_fn no_gen
<- tcInferFRR (FRRBinder name) $ \ exp_ty ->
-- tcInferFRR: the type of a let-binder must have
-- a fixed runtime rep. See #23176
- tcMatchesFun (InfSigCtxt name) mult matches [] exp_ty
+ tcFunBindMatches (InfSigCtxt name) name mult matches [] exp_ty
; mono_id <- newLetBndr no_gen name mult rhs_ty'
; return (unitBag $ L b_loc $
@@ -1634,9 +1640,10 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { let mono_ty = idType mono_id
+ mono_name = idName mono_id
; traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr mono_ty)
- ; (co_fn, matches') <- tcMatchesFun (InfSigCtxt (idName mono_id)) mult
- matches [] (mkCheckExpType mono_ty)
+ ; (co_fn, matches') <- tcFunBindMatches (InfSigCtxt mono_name) mono_name mult
+ matches [] (mkCheckExpType mono_ty)
; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
, fun_matches = matches'
, fun_ext = (co_fn, [])
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -57,7 +57,8 @@ import GHC.Rename.Expr ( mkExpandedExpr )
import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
-import GHC.Tc.Gen.Match
+import GHC.Tc.Gen.Match( TcMatchCtxt(..), tcBody, tcLambdaMatches, tcCaseMatches
+ , tcGRHS, tcDoStmts )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Zonk.TcType
@@ -180,7 +181,7 @@ tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
-- We begin with a special case for HsLam, in case the pushed-down type
-- is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int
tcPolyExpr e@(HsLam x lam_variant matches) res_ty
- = do { (wrap, matches') <- tcMatchLambda e lam_variant matches [] res_ty
+ = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
-- This HsPar case means that the lambda can be wrapped in parens
@@ -280,7 +281,7 @@ tcExpr e@(HsIPVar _ x) res_ty
origin = IPOccOrigin x
tcExpr e@(HsLam x lam_variant matches) res_ty
- = do { (wrap, matches') <- tcMatchLambda e lam_variant matches [] res_ty
+ = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
{-
@@ -380,7 +381,7 @@ tcExpr (HsCase x scrut matches) res_ty
mult <- newFlexiTyVarTy multiplicityTy
-- Typecheck the scrutinee. We use tcInferRho but tcInferSigma
- -- would also be possible (tcMatchesCase accepts sigma-types)
+ -- would also be possible (tcCaseMatches accepts sigma-types)
-- Interesting litmus test: do these two behave the same?
-- case id of {..}
-- case (\v -> v) of {..}
@@ -389,7 +390,7 @@ tcExpr (HsCase x scrut matches) res_ty
; traceTc "HsCase" (ppr scrut_ty)
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
- ; (mult_co_wrap, matches') <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
+ ; (mult_co_wrap, matches') <- tcCaseMatches match_ctxt (Scaled mult scrut_ty) matches res_ty
; return (HsCase x (mkLHsWrap mult_co_wrap scrut') matches') }
where
match_ctxt = MC { mc_what = x,
@@ -427,11 +428,14 @@ Not using 'sup' caused #23814.
-}
tcExpr (HsMultiIf _ alts) res_ty
- = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts
+ = do { (ues, alts') <- mapAndUnzipM tc_alt alts
; res_ty <- readExpType res_ty
; tcEmitBindingUsage (supUEs ues) -- See Note [MultiWayIf linearity checking]
; return (HsMultiIf res_ty alts') }
- where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+ where
+ match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+ tc_alt alt = tcCollectingUsage $
+ wrapLocMA (tcGRHS match_ctxt res_ty) alt
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -30,7 +30,7 @@ module GHC.Tc.Gen.Head
, addHeadCtxt, addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprNC )
-import {-# SOURCE #-} GHC.Tc.Gen.Match( tcMatchLambda )
+import {-# SOURCE #-} GHC.Tc.Gen.Match( tcLambdaMatches )
import GHC.Prelude
import GHC.Hs
@@ -994,7 +994,7 @@ tcExprSig expr (TcCompleteSig sig)
-- (\@a -> blah) :: forall b. woo
go (L loc e@(HsLam x lam_variant matches))
= setSrcSpanA loc $
- do { (wrap, matches') <- tcMatchLambda e lam_variant matches pat_tys rho_ty
+ do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys rho_ty
; return (L loc $ mkHsWrap wrap $ HsLam x lam_variant matches') }
go (L _ (HsPar _ expr)) = go expr
go expr -- Even though we have skolemised, call tcCheckPolyExpr so that
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -15,11 +15,11 @@
-- | Typecheck some @Matches@
module GHC.Tc.Gen.Match
- ( tcMatchesFun
+ ( tcFunBindMatches
+ , tcCaseMatches
+ , tcLambdaMatches
, tcGRHS
, tcGRHSsPat
- , tcMatchesCase
- , tcMatchLambda
, TcMatchCtxt(..)
, TcStmtChecker
, TcExprStmtChecker
@@ -74,6 +74,7 @@ import GHC.Driver.DynFlags ( getDynFlags )
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
+import GHC.Types.Basic( Arity )
import Control.Monad
import Control.Arrow ( second )
@@ -84,32 +85,28 @@ import GHC.Types.Basic (TopLevelFlag(..))
{-
************************************************************************
* *
-\subsection{tcMatchesFun, tcMatchesCase}
+\subsection{tcFunBindMatches, tcCaseMatches}
* *
************************************************************************
- at tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
- at FunMonoBind@. The second argument is the name of the function, which
+`tcFunBindMatches` typechecks a `[Match]` list which occurs in a
+`FunBind`. The second argument is the name of the function, which
is used in error messages. It checks that all the equations have the
-same number of arguments before using @tcMatches@ to do the work.
+same number of arguments before using `tcMatches` to do the work.
-}
-tcMatchesFun :: UserTypeCtxt
- -> Mult -- The multiplicity of the binder
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> [ExpPatType] -- Scoped skolemised binders
- -> ExpSigmaType -- Expected type of function
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchesFun ctxt mult matches invis_pat_tys exp_ty
+tcFunBindMatches :: UserTypeCtxt -> Name
+ -> Mult -- The multiplicity of the binder
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> [ExpPatType] -- Scoped skolemised binders
+ -> ExpSigmaType -- Expected type of function
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty
= assertPpr (funBindPrecondition matches) (pprMatches matches) $
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
- -- sensible location. Note: we have to do this odd
- -- ann-grabbing, because we don't always have annotations in
- -- hand when we call tcMatchesFun...
- traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
- ; checkArgCounts hs_match_ctxt matches
+ arity <- checkArgCounts hs_match_ctxt matches
+
+ ; traceTc "tcFunBindMatches" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
; (wrap_fun, (wrap_mult, r))
<- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
@@ -118,8 +115,8 @@ tcMatchesFun ctxt mult matches invis_pat_tys exp_ty
-- consuming its rhs Many times.
tcExtendBinderStack [mk_binder_stack_item fun_name mult exp_ty pat_tys rhs_ty] $
- do { traceTc "tcMatchesFun" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys
- , ppr pat_tys $$ ppr exp_ty ])
+ do { traceTc "tcFunBindMatches" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys
+ , ppr pat_tys $$ ppr exp_ty ])
; tcMatches tc_match_ctxt (invis_pat_tys ++ pat_tys) rhs_ty matches }
; return (wrap_fun <.> wrap_mult, r) }
@@ -128,10 +125,8 @@ tcMatchesFun ctxt mult matches invis_pat_tys exp_ty
match1 :: Match GhcRn (LHsExpr GhcRn)
hs_match_ctxt :: HsMatchContext GhcRn
(L _ match1 : _) = unLoc (mg_alts matches)
- Match { m_pats = pats1, m_ctxt = hs_match_ctxt } = match1
- FunRhs { mc_fun = L _ fun_name } = hs_match_ctxt
+ Match { m_ctxt = hs_match_ctxt } = match1
- arity = length pats1
tc_match_ctxt = MC { mc_what = hs_match_ctxt, mc_body = tcBody }
herald = ExpectedFunTyMatches (NameThing fun_name) matches
@@ -155,17 +150,17 @@ funBindPrecondition (MG { mg_alts = L _ alts })
is_fun_rhs (L _ (Match { m_ctxt = FunRhs {} })) = True
is_fun_rhs _ = False
-tcMatchLambda :: HsExpr GhcRn -> HsLamVariant
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> [ExpPatType] -- Already skolemised
- -> ExpSigmaType -- NB can be a sigma-type
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchLambda e lam_variant matches invis_pat_tys res_ty
- = do { checkArgCounts (mc_what match_ctxt) matches
+tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> [ExpPatType] -- Already skolemised
+ -> ExpSigmaType -- NB can be a sigma-type
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcLambdaMatches e lam_variant matches invis_pat_tys res_ty
+ = do { arity <- checkArgCounts (mc_what match_ctxt) matches
-- Check argument counts since this is also used for \cases
; (wrapper, (mult_co_wrap, r))
- <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
+ <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt (invis_pat_tys ++ pat_tys) rhs_ty matches
; return (wrapper <.> mult_co_wrap, r) }
@@ -174,15 +169,12 @@ tcMatchLambda e lam_variant matches invis_pat_tys res_ty
herald = ExpectedFunTyLam lam_variant e
-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
- n_pats | isEmptyMatchGroup matches = 1 -- must be lambda-case
- | otherwise = matchGroupArity matches
-
{-
- at tcMatchesCase@ doesn't do the argument-count check because the
+ at tcCaseMatches@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
-}
-tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) =>
+tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) =>
TcMatchCtxt body -- ^ Case context
-> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
@@ -191,7 +183,7 @@ tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) =>
-- Translated alternatives
-- wrapper goes from MatchGroup's ty to expected ty
-tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
+tcCaseMatches ctxt (Scaled scrut_mult scrut_ty) matches res_ty
= tcMatches ctxt [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind at .
@@ -1212,25 +1204,33 @@ the variables they bind into scope, and typecheck the thing_inside.
-}
-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
--- number of args are used in each equation.
+-- number of /required/ args are used in each equation.
+-- Returns the arity, the number of required args
+-- E.g. f @a True y = ...
+-- f False z = ...
+-- The MatchGroup for `f` has arity 2, not 3
checkArgCounts :: AnnoBody body
- => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
- -> TcM ()
+ => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+ -> TcM Arity
checkArgCounts _ (MG { mg_alts = L _ [] })
- = return ()
+ = return 1 -- See Note [Empty MatchGroups] in GHC.Rename.Bind
+ -- case e of {} or \case {}
+ -- Both have arity 1
+
checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
| null matches -- There was only one match; nothing to check
- = return ()
+ = return n_args1
-- Two or more matches: check that they agree on arity
| Just bad_matches <- mb_bad_matches
= failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
$ MatchArgMatches match1 bad_matches
| otherwise
- = return ()
+ = return n_args1
where
- n_args1 = args_in_match match1
- mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1]
+ n_args1 = reqd_args_in_match match1
+ mb_bad_matches = NE.nonEmpty [m | m <- matches, reqd_args_in_match m /= n_args1]
- args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
- args_in_match (L _ (Match { m_pats = pats })) = length pats
+ reqd_args_in_match :: LocatedA (Match GhcRn body1) -> Arity
+ -- Counts the number of /required/ args in the match
+ reqd_args_in_match (L _ (Match { m_pats = pats })) = length pats
=====================================
compiler/GHC/Tc/Gen/Match.hs-boot
=====================================
@@ -4,6 +4,7 @@ import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType )
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.Origin ( UserTypeCtxt )
import GHC.Tc.Types.Evidence ( HsWrapper )
+import GHC.Types.Name ( Name )
import GHC.Hs.Extension ( GhcRn, GhcTc )
tcGRHSsPat :: Mult
@@ -11,15 +12,15 @@ tcGRHSsPat :: Mult
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-tcMatchesFun :: UserTypeCtxt
- -> Mult
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> [ExpPatType]
- -> ExpSigmaType
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcFunBindMatches :: UserTypeCtxt -> Name
+ -> Mult
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> [ExpPatType]
+ -> ExpSigmaType
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchLambda :: HsExpr GhcRn -> HsLamVariant
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> [ExpPatType]
- -> ExpSigmaType
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> [ExpPatType]
+ -> ExpSigmaType
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
=====================================
compiler/GHC/Tc/Types/BasicTypes.hs
=====================================
@@ -203,7 +203,7 @@ data TcIdSigInst
Note that "sig_inst_tau" might actually be a polymorphic type,
if the original function had a signature like
forall a. Eq a => forall b. Ord b => ....
-But that's ok: tcMatchesFun (called by tcRhs) can deal with that
+But that's ok: tcFunBindMatches (called by tcRhs) can deal with that
It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class.
Note [Quantified variables in partial type signatures]
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -177,12 +177,11 @@ matchActualFunTySigma herald mb_thing err_info fun_ty
------------
defer fun_ty
- = do { arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald 1)
+ = do { arg_ty <- new_check_arg_ty herald 1
; res_ty <- newOpenFlexiTyVarTy
- ; mult <- newFlexiTyVarTy multiplicityTy
- ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty
+ ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty
; co <- unifyType mb_thing fun_ty unif_fun_ty
- ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) }
+ ; return (mkWpCastN co, arg_ty, res_ty) }
------------
mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
@@ -347,7 +346,7 @@ Example:
The body of `f` is a lambda abstraction, so we must be able to split off
one argument type from its type. This is handled by `matchExpectedFunTys`
- (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that
+ (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that
looks like this:
f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))
@@ -388,10 +387,23 @@ matchExpectedFunTys :: forall a.
-- Postcondition:
-- If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{}
-- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{}
-matchExpectedFunTys herald ctx arity exp_ty thing_inside
- = case exp_ty of
- Check ty -> check 0 [] ty
- _ -> defer 0 [] exp_ty
+matchExpectedFunTys herald _ arity (Infer inf_res) thing_inside
+ = do { arg_tys <- mapM new_infer_arg_ty [1 .. arity]
+ ; res_ty <- newInferExpType
+ ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty
+ ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys
+ ; res_ty <- readExpType res_ty
+ ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res
+ ; return (mkWpCastN co, result) }
+ where
+ new_infer_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR)
+ new_infer_arg_ty arg_pos -- position for error messages only
+ = do { mult <- newFlexiTyVarTy multiplicityTy
+ ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
+ ; return (mkScaled mult inf_hole) }
+
+matchExpectedFunTys herald ctx arity (Check ty) thing_inside
+ = check 0 [] ty
where
check :: Arity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a)
-- `check` is called only in the Check{} case
@@ -442,7 +454,8 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside
; let wrap_gen = mkWpVisTyLam tv' body_ty' <.> mkWpLet ev_binds
; return (wrap_gen <.> wrap_res, result) }
- check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty })
+ check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult
+ , ft_arg = arg_ty, ft_res = res_ty })
= assert (isVisibleFunArg af) $
do { let arg_pos = n_so_far + 1
; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
@@ -458,7 +471,7 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside
= do { cts <- readMetaTyVar tv
; case cts of
Indirect ty' -> check n_so_far rev_pat_tys ty'
- Flexi -> defer n_so_far rev_pat_tys (mkCheckExpType ty) }
+ Flexi -> defer n_so_far rev_pat_tys ty }
-- In all other cases we bale out into ordinary unification
-- However unlike the meta-tyvar case, we are sure that the
@@ -477,28 +490,28 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside
-- anyway, because it may be useful. See also #9605.
check n_so_far rev_pat_tys res_ty
= addErrCtxtM (mkFunTysMsg herald arity fun_ty) $
- defer n_so_far rev_pat_tys res_exp_ty
+ defer n_so_far rev_pat_tys res_ty
where
res_exp_ty = mkCheckExpType res_ty
fun_ty = reconstructCheckType (reverse rev_pat_tys) res_exp_ty
------------
- defer :: Arity -> [ExpPatType] -> ExpRhoType -> TcM (HsWrapper, a)
+ defer :: Arity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a)
defer n_so_far rev_pat_tys fun_ty
- = do { more_arg_tys <- mapM new_exp_arg_ty [n_so_far + 1 .. arity]
- ; res_ty <- newInferExpType
- ; result <- thing_inside (reverse rev_pat_tys ++ map ExpFunPatTy more_arg_tys) res_ty
- ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys
- ; res_ty <- readExpType res_ty
- ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty
- ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty
- -- Not a good origin at all :-(
- ; return (wrap, result) }
-
- new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR)
- new_exp_arg_ty arg_pos -- position for error messages only
- = mkScaled <$> newFlexiTyVarTy multiplicityTy
- <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
+ = do { more_arg_tys <- mapM (new_check_arg_ty herald) [n_so_far + 1 .. arity]
+ ; let all_pats = reverse rev_pat_tys ++
+ map (ExpFunPatTy . fmap mkCheckExpType) more_arg_tys
+ ; res_ty <- newOpenFlexiTyVarTy
+ ; result <- thing_inside all_pats (mkCheckExpType res_ty)
+
+ ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty
+ ; return (mkWpCastN co, result) }
+
+new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)
+new_check_arg_ty herald arg_pos -- Position for error messages only
+ = do { mult <- newFlexiTyVarTy multiplicityTy
+ ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)
+ ; return (mkScaled mult arg_ty) }
mkFunTysMsg :: ExpectedFunTyOrigin
-> Arity
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -308,9 +308,9 @@ data HsExpr p
| HsLam (XLam p)
HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases
(MatchGroup p (LHsExpr p))
- -- ^ LamSingle: one match
+ -- ^ LamSingle: one match of arity >= 1
-- LamCase: many arity-1 matches
- -- LamCases: many matches of uniform arity
+ -- LamCases: many matches of uniform arity >= 1
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
-- 'GHC.Parser.Annotation.AnnRarrow',
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee179934b4ad3eb3ad68bccc7a0c6c148b445562
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee179934b4ad3eb3ad68bccc7a0c6c148b445562
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240105/2935a9f6/attachment-0001.html>
More information about the ghc-commits
mailing list