From fff3f34df137ab6e47068bb4409d95669fab5095 Mon Sep 17 00:00:00 2001 From: DanielRrr Date: Wed, 3 Nov 2021 22:19:23 +0300 Subject: all the other stuff --- compiler/GHC/HsToCore/Arrows.hs | 14 +-- compiler/GHC/HsToCore/Coverage.hs | 4 +- compiler/GHC/HsToCore/Expr.hs | 12 +-- compiler/GHC/HsToCore/GuardedRHSs.hs | 2 +- compiler/GHC/HsToCore/ListComp.hs | 6 +- compiler/GHC/HsToCore/Match.hs | 52 +++++++----- compiler/GHC/HsToCore/Match.hs-boot | 6 +- compiler/GHC/HsToCore/Match/Constructor.hs | 26 +++--- compiler/GHC/HsToCore/Match/Literal.hs | 8 +- compiler/GHC/HsToCore/Monad.hs | 2 +- compiler/GHC/HsToCore/Pmc.hs | 13 ++- compiler/GHC/HsToCore/Pmc/Desugar.hs | 18 +++- compiler/GHC/HsToCore/Quote.hs | 10 +-- compiler/GHC/HsToCore/Utils.hs | 34 ++++++-- compiler/GHC/Tc/Gen/Arrow.hs | 8 +- compiler/GHC/Tc/Gen/Bind.hs | 10 +-- compiler/GHC/Tc/Gen/Expr.hs | 11 ++- compiler/GHC/Tc/Gen/Match.hs | 48 ++++++----- compiler/GHC/Tc/Gen/Pat.hs | 39 +++++++-- compiler/GHC/Tc/TyCl/Utils.hs | 4 +- compiler/GHC/Tc/Utils/Unify.hs | 132 ++++++++++++++++++++--------- compiler/GHC/Tc/Utils/Zonk.hs | 17 +++- utils/haddock | 2 +- 23 files changed, 315 insertions(+), 163 deletions(-) diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 3d93e0b7a5..5758ba8b74 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -286,8 +286,8 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty var <- selectSimpleMatchVarL Many pat - match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr let pat_ty = hsLPatType pat + match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) (mkVisPat pat) env_stk_expr fail_expr let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd @@ -559,7 +559,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do arg_id <- newSysLocalDs arg_mult arg_ty let case_cmd = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg - dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids + dsCmdLam ids local_vars stack_ty res_ty [mkVisPat (nlVarPat arg_id)] case_cmd env_ids -- D; ys |-a cmd : stk --> t -- ---------------------------------- @@ -691,7 +691,7 @@ dsCmdLam :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command - -> [LPat GhcTc] -- argument patterns to desugar + -> [LMatchPat GhcTc] -- argument patterns to desugar -> LHsCmd GhcTc -- body to desugar -> [Id] -- list of vars in the input to this command -- This is typically fed back, @@ -699,7 +699,7 @@ dsCmdLam :: DsCmdEnv -- arrow combinators -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do - let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) + let pat_vars = mkVarSet (collectLMatchPatsBinders CollWithDictBinders pats) let local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') @@ -865,7 +865,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty pat_id <- selectSimpleMatchVarL Many pat match_code - <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr + <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) (mkVisPat pat) body_expr fail_expr pair_id <- newSysLocalDs Many after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -1094,7 +1094,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" matchSimplys :: [CoreExpr] -- Scrutinees -> HsMatchContext GhcRn -- Match kind - -> [LPat GhcTc] -- Patterns they should match + -> [LMatchPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't -> DsM CoreExpr @@ -1111,7 +1111,7 @@ leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc)) leavesMatch (L _ (Match { m_pats = pats , m_grhss = GRHSs _ grhss binds })) = let - defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) + defined_vars = mkVarSet (collectLMatchPatsBinders CollWithDictBinders pats) `unionVarSet` mkVarSet (collectLocalBinders CollWithDictBinders binds) in diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 2e45539fba..a6ebd06e38 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -667,7 +667,7 @@ addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals (collectLMatchPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } @@ -922,7 +922,7 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals (collectLMatchPatsBinders CollNoDictBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index f818be46a1..e8a656203c 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -207,11 +207,11 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss -- ==> case rhs of C x# y# -> body do { match_nablas <- pmcGRHSs PatBindGuards grhss ; rhs <- dsGuarded grhss ty match_nablas - ; let upat = unLoc pat + ; let upat = VisPat noExtField pat eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar Many upat + ; var <- selectMatchPatVar Many upat -- `var` will end up in a let binder, so the multiplicity -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -722,7 +722,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields , cpt_wrap = req_wrap } } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } + ; return (mkSimpleMatch RecUpd [mkVisPat pat] wrapped_rhs) } {- Note [Scrutinee in Record updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -927,7 +927,7 @@ dsDo ctx stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat - ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) (mkVisPat pat) (xbstc_boundResultType xbs) (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] } @@ -948,7 +948,7 @@ dsDo ctx stmts ; let match_args (pat, fail_op) (vs,body) = do { var <- selectSimpleMatchVarL Many pat - ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) (mkVisPat pat) body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op ; return (var:vs, match_code) @@ -990,7 +990,7 @@ dsDo ctx stmts mfix_arg = noLocA $ HsLam noExtField (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr - [mfix_pat] body] + [mkVisPat mfix_pat] body] , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty , mg_origin = Generated }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 8ecf6c84ed..8d440219b6 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -137,7 +137,7 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do match_result <- matchGuards stmts ctx nablas rhs rhs_ty core_rhs <- dsLExpr bind_rhs match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx) - pat rhs_ty match_result + (mkVisPat pat) rhs_ty match_result pure $ bindNonRec match_var core_rhs <$> match_result' matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt" diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 12a40e6c90..9c42d87c6c 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -285,7 +285,7 @@ deBindComp pat core_list1 quals core_list2 = do letrec_body = App (Var h) core_list1 rest_expr <- deListComp quals core_fail - core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail + core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) (mkVisPat pat) rest_expr core_fail let rhs = Lam u1 $ @@ -374,7 +374,7 @@ dfBindComp c_id n_id (pat, core_list1) quals = do -- build the pattern match core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp)) - pat core_rest (Var b) + (mkVisPat pat) core_rest (Var b) -- now build the outermost foldr, and return mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 @@ -611,7 +611,7 @@ dsMcBindStmt :: LPat GhcTc dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts ; var <- selectSimpleMatchVarL Many pat - ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat + ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) (mkVisPat pat) res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index a4cdb78f6d..4a503051e4 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -275,7 +275,7 @@ matchBangs (var :| vars) ty eqns matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Apply the coercion to the match variable and then match that matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) - = do { let XPat (CoPat co pat _) = firstPat eqn1 + = do { let VisPat _ (L _ (XPat (CoPat co pat _))) = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var (idMult var) pat_ty' ; match_result <- match (var':vars) ty $ NEL.toList $ @@ -290,7 +290,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let TcViewPat viewExpr pat = firstPat eqn1 + let VisPat _ (L _ (TcViewPat viewExpr pat)) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var (idMult var) pat_ty' @@ -303,17 +303,17 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _)) match_result) } -- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo +decomposeFirstPat :: (MatchPat GhcTc -> MatchPat GhcTc) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc -getCoPat (XPat (CoPat _ pat _)) = pat +getCoPat, getBangPat, getViewPat :: MatchPat GhcTc -> MatchPat GhcTc +getCoPat (VisPat _ (L _ (XPat (CoPat _ pat _)))) = VisPat noExtField (L noSrcSpanA pat) getCoPat _ = panic "getCoPat" -getBangPat (BangPat _ pat ) = unLoc pat +getBangPat (VisPat _ (L _ (BangPat _ pat))) = VisPat noExtField pat getBangPat _ = panic "getBangPat" -getViewPat (TcViewPat _ pat) = pat +getViewPat (VisPat _ (L _ (TcViewPat _ pat))) = VisPat noExtField (L noSrcSpanA pat) getViewPat _ = panic "getViewPat" -- | Use this pattern synonym to match on a 'ViewPat'. @@ -403,9 +403,20 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) = panic "tidyEqnInfo" tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) - = do { (wrap, pat') <- tidy1 v orig pat + = do { (wrap, pat') <- tidy1' v orig pat ; return (wrap, eqn { eqn_pats = pat' : pats }) } +tidy1' :: Id + -> Origin + -> MatchPat GhcTc + -> DsM (DsWrapper, + MatchPat GhcTc) +tidy1' v o (VisPat ty (L src pat)) = + do { (wrapper, pat') <- tidy1 v o pat + ; return (wrapper, VisPat ty (L src pat')) } +tidy1' _ _ var@(InvisTyVarPat _ _) = return (idDsWrapper, var) +tidy1' _ _ wild@(InvisWildTyPat _) = return (idDsWrapper, wild) + tidy1 :: Id -- The Id being scrutinised -> Origin -- Was this a pattern the user wrote? -> Pat GhcTc -- The pattern against which it is to be matched @@ -752,10 +763,10 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> - selectMatchVars (zipWithEqual "matchWrapper" - (\a b -> (scaledMult a, unLoc b)) - arg_tys - (hsLMatchPats m)) + selectMatchPatVars (zipWithEqual "matchWrapper" + (\a b -> (scaledMult a, unLoc b)) + arg_tys + (hsLMatchPats m)) -- Pattern match check warnings for /this match-group/. -- @rhss_nablas@ is a flat list of covered Nablas for each RHS. @@ -776,7 +787,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas) = do { dflags <- getDynFlags - ; let upats = map (unLoc . decideBangHood dflags) pats + ; let upats = map (unLoc . decideBangHoodMatch dflags) pats -- pat_nablas is the covered set *after* matching the pattern, but -- before any of the GRHSs. We extend the environment with pat_nablas -- (via updPmNablas) so that the where-clause of 'grhss' can profit @@ -816,7 +827,7 @@ matchEquations ctxt vars eqns_info rhs_ty -- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee -> HsMatchContext GhcRn -- ^ Match kind - -> LPat GhcTc -- ^ Pattern it should match + -> LMatchPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't -> DsM CoreExpr @@ -837,7 +848,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc +matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LMatchPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar @@ -851,7 +862,7 @@ matchSinglePat (Var var) ctx pat ty match_result = matchSinglePatVar var Nothing ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL Many pat + = do { var <- selectMatchPatVarL Many pat -- matchSinglePat is only used in matchSimply, which -- is used in list comprehension, arrow notation, -- and to create field selectors. All of which only @@ -863,7 +874,7 @@ matchSinglePat scrut hs_ctx pat ty match_result matchSinglePatVar :: Id -- See Note [Match Ids] -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to - -> HsMatchContext GhcRn -> LPat GhcTc + -> HsMatchContext GhcRn -> LMatchPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result = assertPpr (isInternalName (idName var)) (ppr var) $ @@ -872,14 +883,13 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result -- Pattern match check warnings ; when (isMatchContextPmChecked dflags FromSource ctx) $ addCoreScrutTmCs mb_scrut [var] $ - pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + pmcMatchPatBind (DsMatchContext ctx locn) var (unLoc pat) - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] + ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHoodMatch dflags pat)] , eqn_orig = FromSource , eqn_rhs = match_result } ; match [var] ty [eqn_info] } - {- ************************************************************************ * * @@ -931,7 +941,7 @@ groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInf -- (b) none of the gi are empty -- The ordering of equations is unchanged groupEquations platform eqns - = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns] + = NEL.groupBy same_gp $ [(patGroup platform (firstPat' eqn), eqn) | eqn <- eqns] -- comprehension on NonEmpty where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index e163a0bde2..7b16eb465f 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -5,7 +5,7 @@ import GHC.Types.Var ( Id ) import GHC.Tc.Utils.TcType ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) -import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import GHC.Hs ( LMatchPat, HsMatchContext, MatchGroup, LHsExpr ) import GHC.Hs.Extension ( GhcTc, GhcRn ) match :: [Id] @@ -22,7 +22,7 @@ matchWrapper matchSimply :: CoreExpr -> HsMatchContext GhcRn - -> LPat GhcTc + -> LMatchPat GhcTc -> CoreExpr -> CoreExpr -> DsM CoreExpr @@ -31,7 +31,7 @@ matchSinglePatVar :: Id -> Maybe CoreExpr -> HsMatchContext GhcRn - -> LPat GhcTc + -> LMatchPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index 1e56808278..ee0f57b362 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -154,21 +154,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct } shift (_, eqn@(EqnInfo - { eqn_pats = ConPat + { eqn_pats = VisPat _ (L _ (ConPat { pat_args = args , pat_con_ext = ConPatTc { cpt_tvs = tvs , cpt_dicts = ds , cpt_binds = bind } - } : pats + })) : pats })) = do ds_bind <- dsTcEvBinds bind return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkCoreLets ds_bind , eqn { eqn_orig = Generated - , eqn_pats = conArgPats val_arg_tys args ++ pats } + , eqn_pats = ((\pat -> VisPat noExtField (L noSrcSpanA pat)) <$> (conArgPats val_arg_tys args)) ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys @@ -185,7 +185,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct -- Divide into sub-groups; see Note [Record patterns] ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) + groups = groupBy compatible_pats [ (pat_args (firstPat' eqn), eqn) | eqn <- eqn1:eqns ] ; match_results <- mapM (match_group arg_vars) groups @@ -195,15 +195,15 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPat { pat_con = L _ con1 - , pat_args = args1 - , pat_con_ext = ConPatTc - { cpt_arg_tys = arg_tys - , cpt_wrap = wrapper1 - , cpt_tvs = tvs1 - , cpt_dicts = dicts1 - } - } = firstPat eqn1 + VisPat _ (L _ (ConPat { pat_con = L _ con1 + , pat_args = args1 + , pat_con_ext = ConPatTc + { cpt_arg_tys = arg_tys + , cpt_wrap = wrapper1 + , cpt_tvs = tvs1 + , cpt_dicts = dicts1 + } + })) = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) ex_tvs = conLikeExTyCoVars con1 diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index a581a961b5..b70a7f2c07 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -602,7 +602,7 @@ matchLiterals (var :| vars) ty sub_groups match_group eqns@(firstEqn :| _) = do { dflags <- getDynFlags ; let platform = targetPlatform dflags - ; let LitPat _ hs_lit = firstPat firstEqn + ; let (VisPat _ (L _ (LitPat _ hs_lit))) = firstPat firstEqn ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) ; return (hsLitKey platform hs_lit, match_result) } @@ -651,7 +651,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal - = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let VisPat _ (L _ (NPat _ (L _ lit) mb_neg eq_chk)) = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -681,7 +681,7 @@ We generate: matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) - = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus + = do { let VisPat _ (L _ (NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus)) = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 @@ -694,7 +694,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) fmap (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = VisPat _ (L _ (NPlusKPat _ (L _ n) _ _ _ _)) : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 9211b52fd7..73e6b4a0bf 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -126,7 +126,7 @@ instance Outputable DsMatchContext where ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match data EquationInfo - = EqnInfo { eqn_pats :: [Pat GhcTc] + = EqnInfo { eqn_pats :: [MatchPat GhcTc] -- ^ The patterns for an equation -- -- NB: We have /already/ applied 'decideBangHood' to diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index ab6479f75b..f2278b7472 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -34,7 +34,7 @@ -- 'ldiMatch'. See Section 4.1 of the paper. module GHC.HsToCore.Pmc ( -- Checking and printing - pmcPatBind, pmcMatches, pmcGRHSs, + pmcPatBind, pmcMatchPatBind, pmcMatches, pmcGRHSs, isMatchContextPmChecked, -- See Note [Long-distance information] @@ -108,6 +108,17 @@ pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do formatReportWarnings cirbsPatBind ctxt [var] result pmcPatBind _ _ _ = pure () +pmcMatchPatBind :: DsMatchContext -> Id -> MatchPat GhcTc -> DsM () +-- See Note [pmcPatBind only checks PatBindRhs] +pmcMatchPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do + !missing <- getLdiNablas + pat_bind <- noCheckDs $ desugarMatchPatBind loc var p + tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) + result <- unCA (checkPatBind pat_bind) missing + tracePm "}: " (ppr (cr_uncov result)) + formatReportWarnings cirbsPatBind ctxt [var] result +pmcMatchPatBind _ _ _ = pure () + -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs. pmcGRHSs diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 629f32f3cd..cadf70fea0 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -11,7 +11,7 @@ -- In terms of the paper, this module is concerned with Sections 3.1, Figure 4, -- in particular. module GHC.HsToCore.Pmc.Desugar ( - desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase + desugarPatBind, desugarMatchPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase ) where import GHC.Prelude @@ -254,6 +254,15 @@ desugarPatV pat = do desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd] desugarLPat x = desugarPat x . unLoc +desugarMatchPat :: Id -> MatchPat GhcTc -> DsM [PmGrd] +desugarMatchPat x (VisPat _ pat) = desugarLPat x pat +desugarMatchPat x (InvisTyVarPat _ (L _ lidp)) = + return $ mkPmLetVar x lidp +desugarMatchPat _ (InvisWildTyPat _) = pure [] + +desugarLMatchPat :: Id -> LMatchPat GhcTc -> DsM [PmGrd] +desugarLMatchPat id lmatchpat = desugarMatchPat id (unLoc lmatchpat) + -- | 'desugarLPat', but also select and return a new match var. desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd]) desugarLPatV = desugarPatV . unLoc @@ -320,6 +329,11 @@ desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) desugarPatBind loc var pat = PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat +desugarMatchPatBind :: SrcSpan -> Id -> MatchPat GhcTc -> DsM (PmPatBind Pre) + -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. +desugarMatchPatBind loc var pat = + PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarMatchPat var pat + desugarEmptyCase :: Id -> DsM PmEmptyCase desugarEmptyCase var = pure PmEmptyCase { pe_var = var } @@ -332,7 +346,7 @@ desugarMatches vars matches = -- Desugar a single match desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre) desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do - pats' <- concat <$> zipWithM desugarLPat vars pats + pats' <- concat <$> zipWithM desugarLMatchPat vars pats grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' } diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index d6db406b44..ad0c17e866 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1667,7 +1667,7 @@ the choice in HsExpanded, but it seems simpler to consult the flag (again). -- Building representations of auxiliary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) -repMatchTup (L _ (Match { m_pats = [p] +repMatchTup (L _ (Match { m_pats = [L _ (VisPat _ p)] , m_grhss = GRHSs _ guards wheres })) = do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { @@ -1682,9 +1682,9 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) repClauseTup (L _ (Match { m_pats = ps , m_grhss = GRHSs _ guards wheres })) = - do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps) + do { ss1 <- mkGenSyms (collectLMatchPatsBinders CollNoDictBinders ps) ; addBinds ss1 $ do { - ps1 <- repLPs ps + ps1 <- repLPs (toLPats ps) ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { gs <- repGuards guards @@ -2022,10 +2022,10 @@ repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) repLambda (L _ (Match { m_pats = ps , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _) } )) - = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; + = do { let bndrs = collectLMatchPatsBinders CollNoDictBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( - do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + do { xs <- repLPs (toLPats ps); body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } repLambda (L _ m) = notHandled (ThGuardedLambdas m) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 2ea1bb3cbe..db86bb2cd4 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -16,7 +16,7 @@ This module exports some utility functions of no great interest. -- | Utility functions for constructing Core syntax, principally for desugaring module GHC.HsToCore.Utils ( EquationInfo(..), - firstPat, shiftEqns, + firstPat, firstPat', shiftEqns, MatchResult (..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, @@ -40,8 +40,9 @@ module GHC.HsToCore.Utils ( mkSelectorBinds, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, + selectSimpleMatchVarL, selectMatchPatVarL, selectMatchVars, selectMatchVar, + selectMatchPatVar, selectMatchPatVars, + mkOptTickBox, mkBinaryTickBox, decideBangHood, decideBangHoodMatch, isTrueLHsExpr ) where @@ -146,6 +147,17 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var)) selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) +selectMatchPatVar :: Mult -> MatchPat GhcTc -> DsM Id +selectMatchPatVar w (VisPat _ pat) = selectMatchVar w (unLoc pat) +selectMatchPatVar _ (InvisTyVarPat _ id) = return (localiseId (unLoc id)) +selectMatchPatVar w (InvisWildTyPat ty) = newSysLocalDs w ty + +selectMatchPatVarL :: Mult -> LMatchPat GhcTc -> DsM Id +selectMatchPatVarL w lmatchpat = selectMatchPatVar w (unLoc lmatchpat) + +selectMatchPatVars :: [(Mult, MatchPat GhcTc)] -> DsM [Id] +selectMatchPatVars ps = mapM (uncurry selectMatchPatVar) ps + {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider module M where @@ -196,9 +208,12 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. -} -firstPat :: EquationInfo -> Pat GhcTc +firstPat :: EquationInfo -> MatchPat GhcTc firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn) +firstPat' :: EquationInfo -> Pat GhcTc +firstPat' eqn = assert (notNull (eqn_pats eqn)) $ head (toPats . eqn_pats $ eqn) + shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } @@ -744,7 +759,7 @@ mkSelectorBinds ticks pat val_expr ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs (mkVisPat pat') (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the @@ -759,7 +774,7 @@ mkSelectorBinds ticks pat val_expr | otherwise -- General case (C) = do { tuple_var <- newSysLocalDs Many tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat + ; tuple_expr <- matchSimply val_expr PatBindRhs (mkVisPat pat) local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ @@ -1059,6 +1074,13 @@ decideBangHood dflags lpat BangPat _ _ -> lp _ -> L l (BangPat noExtField lp) +decideBangHoodMatch :: DynFlags + -> LMatchPat GhcTc -- ^ Original pattern + -> LMatchPat GhcTc -- Pattern with bang if necessary +decideBangHoodMatch dflags (L l (VisPat t lpat)) = + (L l (VisPat t (decideBangHood dflags lpat))) +decideBangHoodMatch _ matchpat = matchpat + isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- Returns Just {..} if we're sure that the expression is True diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index da8bf7901f..97c0fc7069 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -269,18 +269,18 @@ tc_cmd env (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + ; arg_tys' <- sequenceA (map (readExpType . mkCheckExpType) arg_tys) -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpanA mtch_loc $ - tcPats (ArrowMatchCtxt KappaExpr) - pats (map (unrestricted . mkCheckExpType) arg_tys) $ + ; (pats', grhss') <- setSrcSpanA mtch_loc $ + tcLMatchPats (ArrowMatchCtxt KappaExpr) pats (unrestricted <$> arg_tys') $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) ; let match' = L mtch_loc (Match { m_ext = noAnn , m_ctxt = ArrowMatchCtxt KappaExpr , m_pats = pats' , m_grhss = grhss' }) - arg_tys = map (unrestricted . hsLPatType) pats' + arg_tys = map (unrestricted . hsLMatchPatType) pats' ; _concrete_evs <- zipWithM diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 93fa9a7e2c..d4e65ba9fe 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -645,10 +645,10 @@ tcPolyCheck prag_fn ; mod <- getModule ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs - ; let bind' = FunBind { fun_id = L nm_loc poly_id2 - , fun_matches = matches' - , fun_ext = wrap_gen <.> wrap_res - , fun_tick = tick } + ; let bind' = FunBind { fun_id = L nm_loc poly_id2 + , fun_matches = matches' + , fun_ext = wrap_gen <.> wrap_res + , fun_tick = tick } export = ABE { abe_ext = noExtField , abe_wrap = idHsWrapper @@ -1507,7 +1507,7 @@ getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds = foldr (get_info . unLoc) [] tc_binds where - get_info (TcFunBind info _ _) rest = info : rest + get_info (TcFunBind info _ _) rest = info : rest get_info (TcPatBind infos _ _ _) rest = infos ++ rest diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index c9e9129251..0d7310e15c 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -83,6 +83,7 @@ import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) +import GHC.Data.FastString (fsLit) import Data.Function import Data.List (partition, sortBy, groupBy, intersect) @@ -1036,13 +1037,15 @@ tcSynArgE orig sigma_ty syn_ty thing_inside ; return (result, mkWpCastN list_co) } go rho_ty (SynFun arg_shape res_shape) - = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty + = do { uniq <- newUnique + ; let name = mkSystemName uniq (mkTyVarOccFS . fsLit $ "var") + ; ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty , ( ( (result, arg_ty, res_ty, op_mult) , res_wrapper ) -- :: res_ty_out "->" res_ty , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out - <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ + <- matchExpectedFunTys herald GenSigCtxt [L noSrcSpanA (VisPat NoExtField (L noSrcSpanA (VarPat noExtField (L noSrcSpanA name))))] (mkCheckExpType rho_ty) $ \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) + do { let arg_tc_ty = varType arg_ty ; res_tc_ty <- expTypeToType res_ty -- another nested arrow is too much for now, @@ -1053,7 +1056,7 @@ tcSynArgE orig sigma_ty syn_ty thing_inside (text "Too many nested arrows in SyntaxOpType" $$ pprCtOrigin orig) - ; let arg_mult = scaledMult arg_ty + ; let arg_mult = Many ; tcSynArgA orig arg_tc_ty [] arg_shape $ \ arg_results arg_res_mults -> tcSynArgE orig res_tc_ty res_shape $ diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 1b2ebf797a..e5f4974c38 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -53,6 +53,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Var(..) ) import GHC.Core.Multiplicity import GHC.Core.UsageEnv @@ -94,7 +95,7 @@ same number of arguments before using @tcMatches@ to do the work. tcMatchesFun :: LocatedN Id -- MatchContext Id -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- Expected type of function + -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body tcMatchesFun fun_id matches exp_ty @@ -107,7 +108,7 @@ tcMatchesFun fun_id matches exp_ty traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) ; checkArgs fun_name matches - ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + ; matchExpectedFunTys herald ctxt lampats exp_ty $ \ pat_vars rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that tcScalingUsage Many $ @@ -117,10 +118,10 @@ tcMatchesFun fun_id matches exp_ty -- being scaled by Many. When let binders come with a -- multiplicity, then @tcMatchesFun@ will have to take -- a multiplicity argument, and scale accordingly. - tcMatches match_ctxt pat_tys rhs_ty matches } + tcMatches match_ctxt pat_vars rhs_ty matches } where fun_name = idName (unLoc fun_id) - arity = matchGroupArity matches + lampats = matchGroupLMatchPats matches herald = text "The equation(s) for" <+> quotes (ppr fun_name) <+> text "have" ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True @@ -153,8 +154,9 @@ tcMatchesCase :: (AnnoBody body) => -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty -tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty - = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches +tcMatchesCase ctxt (Scaled _ scrut_ty) matches res_ty + = do { var <- newFlexiTyVar scrut_ty + ; tcMatches ctxt [var] res_ty matches } tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr @@ -165,8 +167,8 @@ tcMatchLambda herald match_ctxt match res_ty = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match + n_pats | isEmptyMatchGroup match = [] -- must be lambda-case + | otherwise = matchGroupLMatchPats match -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. @@ -213,7 +215,7 @@ type AnnoBody body -- | Type-check a MatchGroup. tcMatches :: (AnnoBody body ) => TcMatchCtxt body - -> [Scaled ExpSigmaType] -- Expected pattern types + -> [Var] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -225,44 +227,44 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches -- when in inference mode, so we must do it ourselves, -- here, using expTypeToType = do { tcEmitBindingUsage bottomUE - ; pat_tys <- mapM scaledExpTypeToType pat_tys + ; let pat_tys' = map (unrestricted . varType) pat_tys ; rhs_ty <- expTypeToType rhs_ty ; _concrete_evs <- zipWithM - (\ i (Scaled _ pat_ty) -> + (\ i pat_ty -> hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty) - [1..] pat_tys + [1..] (varType <$> pat_tys) ; return (MG { mg_alts = L l [] - , mg_ext = MatchGroupTc pat_tys rhs_ty + , mg_ext = MatchGroupTc pat_tys' rhs_ty , mg_origin = origin }) } | otherwise = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches ; let (usages,matches') = unzip umatches ; tcEmitBindingUsage $ supUEs usages - ; pat_tys <- mapM readScaledExpType pat_tys + ; let pat_tys' = map (unrestricted . varType) pat_tys ; rhs_ty <- readExpType rhs_ty ; _concrete_evs <- zipWithM - (\ i (Scaled _ pat_ty) -> + (\ i pat_ty -> hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty) - [1..] pat_tys + [1..] (varType <$> pat_tys) ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty + , mg_ext = MatchGroupTc pat_tys' rhs_ty , mg_origin = origin }) } ------------- tcMatch :: (AnnoBody body) => TcMatchCtxt body - -> [Scaled ExpSigmaType] -- Expected pattern types + -> [Var] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> LMatch GhcRn (LocatedA (body GhcRn)) -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) -tcMatch ctxt pat_tys rhs_ty match - = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match +tcMatch ctxt vars rhs_ty match + = wrapLocMA (tc_match ctxt ((\var -> unrestricted (varType var)) <$> vars) rhs_ty) match where - tc_match ctxt pat_tys rhs_ty - match@(Match { m_pats = pats, m_grhss = grhss }) + tc_match ctxt vars rhs_ty + match@(Match { m_pats = lampats, m_grhss = grhss }) = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ + do { (pats', grhss') <- tcLMatchPats (mc_what ctxt) lampats vars $ tcGRHSs ctxt grhss rhs_ty ; return (Match { m_ext = noAnn , m_ctxt = mc_what ctxt, m_pats = pats' diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index a09d77b6f7..b0177319ad 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -19,7 +19,7 @@ module GHC.Tc.Gen.Pat , newLetBndr , LetBndrSpec(..) , tcCheckPat, tcCheckPat_O, tcInferPat - , tcPats + , tcLMatchPats , addDataConStupidTheta , badFieldCon , polyPatSig @@ -99,11 +99,11 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ; tc_lpat pat_ty penv pat thing_inside } ----------------- -tcPats :: HsMatchContext GhcTc - -> [LPat GhcRn] -- Patterns, - -> [Scaled ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body - -> TcM ([LPat GhcTc], a) +tcLMatchPats :: HsMatchContext GhcTc + -> [LMatchPat GhcRn] -- Patterns, + -> [Scaled Type] -- and their types + -> TcM a -- and the checker for the body + -> TcM ([LMatchPat GhcTc], a) -- This is the externally-callable wrapper function -- Typecheck the patterns, extend the environment to bind the variables, @@ -116,8 +116,8 @@ tcPats :: HsMatchContext GhcTc -- 3. Check the body -- 4. Check that no existentials escape -tcPats ctxt pats pat_tys thing_inside - = tc_lpats pat_tys penv pats thing_inside +tcLMatchPats ctxt pats pat_tys thing_inside + = tc_lmatchpats pat_tys penv pats thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } @@ -340,6 +340,21 @@ tc_lpat pat_ty penv (L span pat) thing_inside thing_inside ; return (L span pat', res) } +tc_lmatchpat :: Scaled Type + -> Checker (LMatchPat GhcRn) (LMatchPat GhcTc) +tc_lmatchpat (Scaled mult ty') penv (L l (VisPat x pat)) thing_inside + = do { (pat', res) <- tc_lpat (Scaled mult (Check ty')) penv pat thing_inside + ; return (L l (VisPat x pat'), res) } +tc_lmatchpat ty _ (L l' (InvisTyVarPat x (L l name))) thing_inside + = do { let ty' = scaledThing ty + ; let var = mkLocalIdOrCoVar name Many ty' + ; (res,_) <- tcCheckUsage name ty' $ tcExtendIdEnv1 name var thing_inside + ; return (L l' (InvisTyVarPat x (L l var)),res) + } +tc_lmatchpat (Scaled _ ty) _ (L l' (InvisWildTyPat _)) thing_inside + = do { res <- thing_inside + ; return (L l' (InvisWildTyPat ty), res) } + tc_lpats :: [Scaled ExpSigmaType] -> Checker [LPat GhcRn] [LPat GhcTc] tc_lpats tys penv pats @@ -348,6 +363,14 @@ tc_lpats tys penv pats penv (zipEqual "tc_lpats" pats tys) +tc_lmatchpats :: [Scaled Type] + -> Checker [LMatchPat GhcRn] [LMatchPat GhcTc] +tc_lmatchpats tys penv pats + = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $ + tcMultiple (\ penv' (p,t) -> tc_lmatchpat t penv' p) + penv + (zipEqual "tc_lampats" pats tys) + -------------------- -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. checkManyPattern :: Scaled a -> TcM HsWrapper diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 1ce9ef8f82..e5e9ffc35c 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -924,7 +924,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc' (mk_sel_pat con)] + [L noSrcSpanA (VisPat noExtField (L loc' (mk_sel_pat con)))] (L loc' (HsVar noExtField (L locn field_var))) mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } @@ -944,7 +944,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc' (WildPat noExtField)] + [L noSrcSpanA (VisPat noExtField (L loc' (WildPat noExtField)))] (mkHsApp (L loc' (HsVar noExtField (L locn (getName rEC_SEL_ERROR_ID)))) (L loc' (HsLit noComments msg_lit)))] diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index a0b8106a8d..fc98de6ef4 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -45,7 +45,6 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Tc.Utils.Concrete ( mkWpFun ) import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -59,9 +58,11 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin import GHC.Types.Name( isSystemName ) - +import GHC.Types.Id +import GHC.Tc.Utils.Instantiate import GHC.Core.TyCon import GHC.Builtin.Types +import GHC.Types.SrcLoc import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -75,9 +76,9 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Exts ( inline ) -import Control.Monad import Control.Arrow ( second ) import qualified Data.Semigroup as S ( (<>) ) +import GHC.Data.FastString {- ********************************************************************* * * @@ -287,49 +288,52 @@ passed in. matchExpectedFunTys :: forall a. SDoc -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt - -> Arity - -> ExpRhoType -- Skolemised - -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a) + -> [LMatchPat GhcRn] + -> ExpSigmaType + -> ([Var] -> ExpSigmaType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (_, wrap) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald ctx arity orig_ty thing_inside +matchExpectedFunTys herald ctx lmatchpats orig_ty thing_inside = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty + Check ty -> go [] lmatchpats ty + _ -> defer [] lmatchpats orig_ty where - -- Skolemise any foralls /before/ the zero-arg case - -- so that we guarantee to return a rho-type - go acc_arg_tys n ty + go vars pats ty | (tvs, theta, _) <- tcSplitSigmaTy ty , not (null tvs && null theta) = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' -> - go acc_arg_tys n ty' + go vars pats ty' + ; return (wrap_gen <.> wrap_res, result) } + + go vars (L _ (InvisTyVarPat _ (L _ _)): pats) (ForAllTy (Bndr var _) ty') + = do { (wrap_res, result) <- go (var : vars) pats ty' + ; let wrap_gen = WpTyLam var ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ tcView, so -- that we do not unnecessarily unwrap synonyms - go acc_arg_tys 0 rho_ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) + go vars [] ty + = do { result <- thing_inside (reverse vars) (mkCheckExpType ty) ; return (idHsWrapper, result) } - go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' + go vars pats ty + | Just ty' <- tcView ty = go vars pats ty' - go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = assert (af == VisArg) $ - do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) - (n-1) res_ty + go vars (L _ (VisPat _ _):pats) (FunTy { ft_mult = mult, ft_af = VisArg, ft_arg = arg_ty, ft_res = res_ty }) + = do { name <- newMetaTyVarName (fsLit "arg") + ; let var = mkLocalId name mult arg_ty + ; (wrap_res, result) <- go (var : vars) pats res_ty ; fun_wrap <- mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty (WpFunFunExpTy orig_ty) ; return ( fun_wrap, result ) } - go acc_arg_tys n ty@(TyVarTy tv) + go vars pats ty@(TyVarTy tv) | isMetaTyVar tv = do { cts <- readMetaTyVar tv ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } + Indirect ty' -> go vars pats ty' + Flexi -> defer vars pats (mkCheckExpType ty) } -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the @@ -346,31 +350,79 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside -- -- But in that case we add specialized type into error context -- anyway, because it may be useful. See also #9605. - go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ - defer acc_arg_tys n (mkCheckExpType ty) + go acc_arg_tys vars ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ + defer acc_arg_tys vars (mkCheckExpType ty) ------------ - defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) - defer acc_arg_tys n fun_ty - = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType) - ; res_ty <- newInferExpType - ; result <- thing_inside (reverse acc_arg_tys ++ 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 = mkVisFunTys more_arg_tys res_ty + + defer :: [Var] -> [LMatchPat GhcRn] -> ExpSigmaType -> TcM (HsWrapper, a) + defer vars pats fun_ty + = do { arg_binds <- sequenceA (lmatch_pats_to_bndrs <$> pats) + ; res_ty <- newInferExpType + ; more_vars <- sequenceA (lampat_to_var <$> pats) + ; result <- thing_inside (reverse vars ++ more_vars) res_ty + ; res_ty <- expTypeToType res_ty + ; let unif_fun_ty = mkPiTys arg_binds res_ty ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty -- Not a good origin at all :-( ; return (wrap, result) } + lampat_to_var (L _ (VisPat _ _)) = + do { name <- newMetaTyVarName (fsLit "arg") + ; ty <- newInferExpType >>= expTypeToType + ; return $ mkLocalId name Many ty + } + lampat_to_var _ = newOpenFlexiTyVar + ------------ - mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) - mk_ctxt arg_tys res_ty env - = mkFunTysMsg env herald arg_tys' res_ty arity - where - arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $ - reverse arg_tys + mk_ctxt :: [Var] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) + mk_ctxt vars res_ty env + = mkPiTysMsg env herald vars res_ty lmatchpats -- this is safe b/c we're called from "go" + lmatch_pats_to_bndrs :: LMatchPat GhcRn -> TcM TyCoBinder + lmatch_pats_to_bndrs (L _ (VisPat _ _)) + = do { fresh <- newInferExpType + ; ty' <- mkScaled <$> newFlexiTyVarTy multiplicityTy <*> (expTypeToType fresh) + ; return $ Anon VisArg ty' } + lmatch_pats_to_bndrs (L _ (InvisTyVarPat _ _)) + = do { var <- newOpenFlexiTyVar + ; return $ Named (Bndr var Specified) } + lmatch_pats_to_bndrs (L _ (InvisWildTyPat _)) + = do { var <- newOpenFlexiTyVar + ; return $ Named (Bndr var Inferred) } + +mkPiTysMsg :: TidyEnv -> SDoc -> [Var] -> TcType -> [LMatchPat GhcRn] + -> TcM (TidyEnv, SDoc) +mkPiTysMsg env herald vars res_ty lmatchpats + = do { let arg_binds = to_arg_bind <$> (zip vars lmatchpats) + ; let fun = mkPiTys arg_binds res_ty + ; (env', fun_ty) <- zonkTidyTcType env fun + ; let (all_arg_tys, _) = splitFunTys fun_ty + n_fun_args = length all_arg_tys + all_lpats = length (toLPats lmatchpats) + + (all_forall_args, _) = splitForAllTyVars fun_ty + n_forall_args = length all_forall_args + all_invis_pats = length (toInvisPats lmatchpats) + + full_herald = herald <+> speakNOf all_lpats (text "value argument") + + msg | all_invis_pats <= n_forall_args && all_lpats <= n_fun_args -- Enough args, in the end + = text "In the result of a function call" + | otherwise + = hang (full_herald <> comma) + 2 (sep [ text "but its type" <+> quotes (pprType fun_ty) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + + ; return (env', msg) } + where + to_arg_bind :: (Var, LMatchPat GhcRn) -> TyCoBinder + to_arg_bind (var, (L _ (VisPat _ _))) = Anon VisArg (Scaled (varMult var) (varType var)) + to_arg_bind (var, (L _ (InvisTyVarPat _ _))) = Named (Bndr var Specified) + to_arg_bind (var, (L _ (InvisWildTyPat _))) = Named (Bndr var Inferred) + mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index fec8d90d5d..1bff9ce013 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -694,7 +694,7 @@ zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkPats env pats + = do { (env1, new_pats) <- zonkLMatchPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } @@ -1338,6 +1338,15 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) -- to the right) zonkPat env pat = wrapLocSndMA (zonk_pat env) pat +zonkLMatchPat :: ZonkEnv -> LMatchPat GhcTc -> TcM (ZonkEnv, LMatchPat GhcTc) +zonkLMatchPat env (L l (VisPat x pat)) + = do { (env', p') <- zonkPat env pat + ; return (env', L l (VisPat x p'))} +zonkLMatchPat env (L l (InvisTyVarPat t (L l' idp))) + = do { (env', (L _ idp')) <- wrapLocSndM (zonkTyBndrX env) (L noSrcSpan idp) + ; return (env', L l (InvisTyVarPat t (L l' idp')))} +zonkLMatchPat env p = return (env, p) + zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x lpar p rpar) = do { (env', p') <- zonkPat env p @@ -1484,6 +1493,12 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ; (env', pats') <- zonkPats env1 pats ; return (env', pat':pats') } +zonkLMatchPats :: ZonkEnv -> [LMatchPat GhcTc] -> TcM (ZonkEnv, [LMatchPat GhcTc]) +zonkLMatchPats env [] = return (env, []) +zonkLMatchPats env (pat:pats) = do { (env1, pat') <- zonkLMatchPat env pat + ; (env', pats') <- zonkLMatchPats env1 pats + ; return (env', pat':pats') } + {- ************************************************************************ * * diff --git a/utils/haddock b/utils/haddock index 1ef24e6176..d8b79d35dd 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 1ef24e617651955f07c4fb6f2d488806cc6785ec +Subproject commit d8b79d35ddd96c83f4a3a0303011defc209aa318 -- cgit v1.2.1