diff options
33 files changed, 130 insertions, 137 deletions
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 66b630e23b..fb903c8a2c 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -37,7 +37,7 @@ module GHC.Hs.Pat ( hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, - mkPrefixConPat, mkCharLitPat, mkNilPat, mkVisPat, expectVisPats, + mkPrefixConPat, mkCharLitPat, mkNilPat, mkVisPat, mkVisPat', expectVisPats, isSimplePat, isSimpleMatchPat, looksLazyPatBind, @@ -187,6 +187,10 @@ type instance XXMatchPat (GhcPass _) = DataConCantHappen mkVisPat :: LPat (GhcPass pass) -> LMatchPat (GhcPass pass) mkVisPat lpat = L (getLoc lpat) (VisPat noExtField lpat) +-- | A helper function that constructs a match pattern from a Pat +mkVisPat' :: Pat (GhcPass pass) -> MatchPat (GhcPass pass) +mkVisPat' pat = VisPat noExtField (L noSrcSpanA pat) + expectVisPats :: [LMatchPat GhcTc] -> [LPat GhcTc] expectVisPats xs = map toLPat xs where diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index b12d1fcc32..da367cb84e 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -79,7 +79,7 @@ module GHC.Hs.Type ( mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigWcType, hsPatSigType, hsTyKindSig, - setHsTyVarBndrFlag, hsTyVarBndrFlag, + setHsTyVarBndrFlag, hsTyVarBndrFlag, hsTyVarBndrTy, -- Printing pprHsType, pprHsForAll, @@ -284,6 +284,10 @@ hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag hsTyVarBndrFlag (UserTyVar _ fl _) = fl hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl +hsTyVarBndrTy :: HsTyVarBndr flag GhcTc -> Type +hsTyVarBndrTy (UserTyVar _ _ lipd) = idType (unLoc lipd) +hsTyVarBndrTy (KindedTyVar _ _ lipd _) = idType (unLoc lipd) + -- | Set the attached flag setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass) -> HsTyVarBndr flag (GhcPass pass) diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index ccf459ae04..32d65606ad 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -278,21 +278,21 @@ mkHsEnvStackExpr env_ids stack_id -- where (xs) is the tuple of variables bound by p dsProcExpr - :: LPat GhcTc + :: LMatchPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders CollWithDictBinders pat) + let locals = mkVarSet (collectLMatchPatBinders CollWithDictBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty - var <- selectSimpleMatchVarL Many pat + var <- selectSimpleMatchPatVarL Many pat match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr - let pat_ty = hsLPatType pat + let pat_ty = hsLMatchPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd @@ -416,7 +416,7 @@ dsCmd ids local_vars stack_ty res_ty = (L _ [L _ (Match { m_pats = pats , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) env_ids - = dsCmdLam ids local_vars stack_ty res_ty (expectVisPats pats) body env_ids + = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids @@ -711,7 +711,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, @@ -719,7 +719,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') @@ -961,7 +961,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) @@ -1190,7 +1190,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 diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index f41c31f082..6a516e9093 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -206,10 +206,10 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss do { match_nablas <- pmcGRHSs PatBindGuards grhss ; rhs <- dsGuarded grhss ty match_nablas ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], + eqn = EqnInfo { eqn_pats = [mkVisPat' upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar Many upat + ; var <- selectMatchVar Many (unLoc pat) -- `var` will end up in a let binder, so the multiplicity -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -521,7 +521,7 @@ dsExpr (HsTypedSplice _ s) = pprPanic "dsExpr:typed splice" (pprTypedSplice dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext -- Arrow notation extension -dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd +dsExpr (HsProc _ pat cmd) = dsProcExpr (mkVisPat pat) cmd -- HsSyn constructs that just shouldn't be here, because @@ -696,7 +696,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] } @@ -717,7 +717,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) 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 5a55570827..7d8f938d35 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -277,7 +277,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 $ @@ -292,7 +292,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' @@ -305,17 +305,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'. @@ -405,9 +405,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 loc pat)) + = do { (wrap, pat') <- tidy1 v o pat + ; return (wrap, VisPat ty (L loc pat')) } +tidy1' _ _ v = return (idDsWrapper, v) + + 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 @@ -773,9 +784,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches [] -> newSysLocalsDs' arg_tys (m:_) -> selectMatchPatVars (zipWithEqual "matchWrapper" - (\a b -> (scaledMult a, unLoc b)) + (\a b -> (scaledMult a, unLoc b)) (map tyCoBinderScaledType arg_tys) - (expectVisPats (hsLMatchPats m))) + (hsLMatchPats m)) -- Pattern match check warnings for /this match-group/. -- @rhss_nablas@ is a flat list of covered Nablas for each RHS. @@ -796,7 +807,7 @@ matchWrapper ctxt scrs (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) (expectVisPats pats) + ; let upats = map (unLoc . decideLMatchPatBangHood 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 @@ -836,7 +847,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 @@ -857,7 +868,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 @@ -871,7 +882,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 <- selectSimpleMatchPatVarL 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 @@ -883,7 +894,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) $ @@ -894,7 +905,7 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result addCoreScrutTmCs (maybeToList mb_scrut) [var] $ pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] + ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideLMatchPatBangHood dflags pat)] , eqn_orig = FromSource , eqn_rhs = match_result } ; match [var] ty [eqn_info] } @@ -951,7 +962,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 $ [(matchPatGroup platform (firstPat eqn), eqn) | eqn <- eqns] -- comprehension on NonEmpty where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool @@ -1196,6 +1207,10 @@ patGroup platform (XPat ext) = case ext of ExpansionPat _ p -> patGroup platform p patGroup _ pat = pprPanic "patGroup" (ppr pat) +matchPatGroup :: Platform -> MatchPat GhcTc -> PatGroup +matchPatGroup platform (VisPat _ lpat) = patGroup platform (unLoc lpat) +matchPatGroup _ _ = PgAny + {- Note [Grouping overloaded literal patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index 3e969e922d..5964d87575 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..18eaee43d8 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 = map mkVisPat' (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 2913404b00..c4930858a2 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 7569dcb701..7dc8cef8b9 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -128,7 +128,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 c810834c64..7510bb1029 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -98,11 +98,11 @@ noCheckDs :: DsM a -> DsM a noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) -- | Check a pattern binding (let, where) for exhaustiveness. -pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () +pmcPatBind :: DsMatchContext -> Id -> MatchPat GhcTc -> DsM () -- See Note [pmcPatBind only checks PatBindRhs] pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do !missing <- getLdiNablas - pat_bind <- noCheckDs $ desugarPatBind loc var p + 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)) diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 3b3ace347c..629940b19f 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 + desugarMatchPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase ) where import GHC.Prelude @@ -103,6 +103,11 @@ mkPmLitGrds x lit = do , pm_con_args = [] } pure [grd] +desugarMatchPat :: Id -> MatchPat GhcTc -> DsM [PmGrd] +desugarMatchPat x (VisPat _ (L _ pat)) = desugarPat x pat +desugarMatchPat x (InvisTyVarPat _ y) = pure (mkPmLetVar (hsLTyVarName y) x) +desugarMatchPat _ (InvisWildTyPat _) = pure [] + -- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where -- the variable representing the match is @x@. desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd] @@ -256,8 +261,7 @@ desugarLPat x = desugarPat x . unLoc -- | Desugar a match pattern desugarLMatchPat :: Id -> LMatchPat GhcTc -> DsM [PmGrd] -desugarLMatchPat x (L _ (VisPat _ pat)) = desugarLPat x pat -desugarLMatchPat _ _ = panic "desugarLMatchPat" +desugarLMatchPat x lmatchpat = desugarMatchPat x (unLoc lmatchpat) -- | 'desugarLPat', but also select and return a new match var. desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd]) @@ -320,10 +324,10 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids) pure (con_grd : arg_grds) -desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) +desugarMatchPatBind :: SrcSpan -> Id -> MatchPat GhcTc -> DsM (PmPatBind Pre) -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. -desugarPatBind loc var pat = - PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat +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 } diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index f2a328956b..32fc7c4f70 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -15,7 +15,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, @@ -39,10 +39,9 @@ module GHC.HsToCore.Utils ( mkSelectorBinds, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - selectMatchPatVars, selectMatchPatVar, - mkOptTickBox, mkBinaryTickBox, decideBangHood, - isTrueLHsExpr + selectSimpleMatchVarL, selectSimpleMatchPatVarL, selectMatchVars, selectMatchPatVar, + selectMatchPatVars, selectMatchVar, mkOptTickBox, mkBinaryTickBox, decideBangHood, + decideLMatchPatBangHood, isTrueLHsExpr ) where import GHC.Prelude @@ -111,6 +110,10 @@ selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id -- Postcondition: the returned Id has an Internal Name selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat) +selectSimpleMatchPatVarL :: Mult -> LMatchPat GhcTc -> DsM Id +-- Postcondition: the returned Id has an Internal Name +selectSimpleMatchPatVarL w pat = selectMatchPatVar w (unLoc pat) + -- (selectMatchVars ps tys) chooses variables of type tys -- to use for matching ps against. If the pattern is a variable, -- we try to use that, to save inventing lots of fresh variables. @@ -148,9 +151,9 @@ selectMatchVar _w (AsPat _ var _ _) = assert (isManyDataConTy _w ) (return (unLo selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) selectMatchPatVar :: Mult -> MatchPat GhcTc -> DsM Id -selectMatchPatVar w (VisPat _ (L _ pat)) = selectMatchVar w pat -selectMatchPatVar _ (InvisTyVarPat _ var) = return (unLoc var) -selectMatchPatVar _ (InvisWildTyPat ty) = newPredVarDs ty +selectMatchPatVar w (VisPat _ (L _ pat)) = selectMatchVar w pat +selectMatchPatVar _ (InvisTyVarPat _ bndr) = return (hsLTyVarName bndr) +selectMatchPatVar _ (InvisWildTyPat ty) = newPredVarDs ty selectMatchPatVars :: [(Mult, MatchPat GhcTc)] -> DsM [Id] selectMatchPatVars ps = mapM (uncurry selectMatchPatVar) ps @@ -205,9 +208,16 @@ 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 (discardLInvisPats' (eqn_pats eqn))) $ head (discardLInvisPats' (eqn_pats eqn)) + where + discardLInvisPats' [] = [] + discardLInvisPats' (VisPat _ pat : xs) = unLoc pat : discardLInvisPats' xs + discardLInvisPats' (_ : xs) = discardLInvisPats' xs + shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } @@ -752,7 +762,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 @@ -767,7 +777,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 $ @@ -1070,6 +1080,13 @@ decideBangHood dflags lpat BangPat _ _ -> lp _ -> L l (BangPat noExtField lp) +decideLMatchPatBangHood :: DynFlags + -> LMatchPat GhcTc + -> LMatchPat GhcTc +decideLMatchPatBangHood dflags (L l (VisPat x lpat)) = + L l (VisPat x (decideBangHood dflags lpat)) +decideLMatchPatBangHood _ 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/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 90c76f09dc..be71b56ae6 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1383,7 +1383,6 @@ isFunLhs e = go e [] [] [] where (o,c) = mkParensEpAnn (realSrcSpan $ locA l) go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps -<<<<<<< HEAD | not (isRdrDataCon op) -- We have found the function! = return (Just (L loc' op, Infix, (mk l:mk r:es), (anns ++ reverse ops ++ cps))) | otherwise -- Infix data con; keep going @@ -1399,35 +1398,6 @@ isFunLhs e = go e [] [] [] go (L _ (PatBuilderAppType pat _ (HsPS _ (L loc hs_ty)))) es ops cps | Just arg <- go_type_arg hs_ty = go pat (L loc (MatchPatBuilderMatchPat arg) : es) ops cps -||||||| parent of cf7104c386 (parser and renamer checkpoint) - | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps))) - | otherwise -- Infix data con; keep going - = do { mb_l <- go l es ops cps - ; case mb_l of - Just (op', Infix, j : k : es', anns') - -> return (Just (op', Infix, j : op_app : es', anns')) - where - op_app = L loc (PatBuilderOpApp k - (L loc' op) r (EpAnn loca (reverse ops++cps) cs)) - _ -> return Nothing } -======= - | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (mk l:mk r:es), (anns ++ reverse ops ++ cps))) - | otherwise -- Infix data con; keep going - = do { mb_l <- go l es ops cps - ; return (join $ fmap reassociate mb_l) } - where - reassociate (op', Infix, j : L k_loc (MatchPatBuilderVisPat k) : es', anns') - = Just (op', Infix, j : op_app : es', anns') - where - op_app = mk $ L loc (PatBuilderOpApp (L k_loc k) (L loc' op) r - (EpAnn loca (reverse ops ++ cps) cs)) - reassociate _other = Nothing - go (L _ (PatBuilderAppType pat (HsPS _ (L loc hs_ty)))) es ops cps - | Just arg <- go_type_arg hs_ty - = go pat (L loc (MatchPatBuilderMatchPat arg) : es) ops cps ->>>>>>> cf7104c386 (parser and renamer checkpoint) go _ _ _ _ = return Nothing go_type_arg :: HsType GhcPs -> Maybe (MatchPat GhcPs) diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 1406c17645..cbac27896d 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -59,7 +59,6 @@ import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Core.TyCon -import GHC.Core.Type ( tyCoBinderScaledType ) -- Create chunkified tuple tybes for monad comprehensions import GHC.Core.Make diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 12fa4e5a88..f242bdffd6 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -23,7 +23,7 @@ import GHC.Prelude import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity -import GHC.Core.Type ( toAnonTyCoBinder, tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) +import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import GHC.Tc.Errors.Types diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index c91db67370..c8876fd65a 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -63,7 +63,6 @@ import GHC.Types.Name( isSystemName ) 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 diff --git a/libraries/array b/libraries/array -Subproject 3e4334a6f39d92090bf3ded86b84d7cd1817ce2 +Subproject 77990b2132ba688f6282822891da2b9455e33c2 diff --git a/libraries/deepseq b/libraries/deepseq -Subproject cc5852e2e19fa5d62b732c9a572a6a6013544a4 +Subproject f241315f4cc905076d5c988c27c7db9fbde8bbe diff --git a/libraries/directory b/libraries/directory -Subproject adb8b4d67356c4eca92f62fd1b7c1ac8add4241 +Subproject 4556d3cb689b8ef7c0f433de3c957559613e342 diff --git a/libraries/filepath b/libraries/filepath -Subproject e60969e693ffea59725cc3ebcae415343ddd069 +Subproject 4d7092ad3a8357b18a8fcbeb6fcf38045460eb9 diff --git a/libraries/haskeline b/libraries/haskeline -Subproject 2a5d9451ab7a0602b604a4bf0b9f950e913b865 +Subproject aae0bfeec7ae767e3c30844ca2f99b682518546 diff --git a/libraries/hpc b/libraries/hpc -Subproject 3648cd63d10e301f3f596efdcb1427a6a6a96cf +Subproject 7d400662546a262b64af49b5707db22e20b8b9d diff --git a/libraries/parsec b/libraries/parsec -Subproject 9a1f72c1c77e3bb9ac2a3ca9b0aedd66f3c7f35 +Subproject a74c68e948c99621100447014f48ccac7ee0448 diff --git a/libraries/process b/libraries/process -Subproject 2ee9f1d8412de2150cb636b524290ceceed682b +Subproject 7a7431a0ef586c0f1e602e382398b988c699dfc diff --git a/libraries/stm b/libraries/stm -Subproject a58fdfadbcfd2743944e6a3c4bc734cfbca8913 +Subproject d4da9d83d1eab562460aa89cedac61abc884d93 diff --git a/libraries/terminfo b/libraries/terminfo -Subproject 5c75033414f7232b007e7dd50d1ea2b0f2147ff +Subproject a21cc7e2d58f3e35a4ac3fb386738d9b448eaf1 diff --git a/nofib b/nofib -Subproject 24a179b18d4aeb2675d22d33a435baeb70183c9 +Subproject 2cee92861c43ac74154bbd155a83f9f4ad0b9f2 diff --git a/testsuite/tests/parser/should_fail/T18251d.stderr b/testsuite/tests/parser/should_fail/T18251d.stderr deleted file mode 100644 index bf82c53290..0000000000 --- a/testsuite/tests/parser/should_fail/T18251d.stderr +++ /dev/null @@ -1,6 +0,0 @@ - -T18251d.hs:6:1: error: - • @-binders in functions are not allowed yet - • In an equation for ‘f’: f @a _ = () - The equation for ‘f’ has two value arguments, - but its type ‘a -> ()’ has only one diff --git a/testsuite/tests/typecheck/should_compile/T17594a.hs b/testsuite/tests/typecheck/should_compile/T17594a.hs index ae5163f747..c43d362a3c 100644 --- a/testsuite/tests/typecheck/should_compile/T17594a.hs +++ b/testsuite/tests/typecheck/should_compile/T17594a.hs @@ -1,13 +1,13 @@ module T17594a where -const'' :: a -> b -> a -const'' @a x _ = x +id1 :: forall a. a -> a +id1 @a x = x -pair :: forall a. a -> (a, a) -pair @a x = (x :: a, x :: a) +id2 :: forall a. a -> a +id2 @_ x = x -id' :: a -> a -id' @a x = x +id3 :: forall a. a -> a +id3 @a (x :: a) = x -const' :: a -> b -> a -const' @a x _ = x +const' :: forall a. a -> forall b. b -> a +const' @a x @b y = x diff --git a/testsuite/tests/typecheck/should_fail/T17594a.hs b/testsuite/tests/typecheck/should_fail/T17594a.hs deleted file mode 100644 index c43d362a3c..0000000000 --- a/testsuite/tests/typecheck/should_fail/T17594a.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T17594a where - -id1 :: forall a. a -> a -id1 @a x = x - -id2 :: forall a. a -> a -id2 @_ x = x - -id3 :: forall a. a -> a -id3 @a (x :: a) = x - -const' :: forall a. a -> forall b. b -> a -const' @a x @b y = x diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject fe518b0e86a45826b5b1f4642037981bac7413d +Subproject ac11465d9aadbe24be4832a3775fbd434448440 |