From 62fbbe95ad21af5a1db3292622d39f1444f52b75 Mon Sep 17 00:00:00 2001 From: Daniel Rogozin Date: Tue, 20 Apr 2021 19:22:56 +0300 Subject: wip --- compiler/GHC/Hs/Expr.hs | 1 + compiler/GHC/Hs/Pat.hs | 2 +- compiler/GHC/Hs/Utils.hs | 5 ++--- compiler/GHC/Parser.y | 11 +++++++++-- compiler/GHC/Parser/Errors.hs | 1 - compiler/GHC/Parser/Errors/Ppr.hs | 2 -- compiler/GHC/Parser/PostProcess.hs | 9 +++++---- compiler/GHC/Tc/Gen/Arrow.hs | 1 - compiler/GHC/Tc/Gen/HsType.hs | 4 +++- compiler/GHC/ThToHs.hs | 3 ++- 10 files changed, 23 insertions(+), 16 deletions(-) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 436da995a7..09d22102e2 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -31,6 +31,7 @@ module GHC.Hs.Expr #include "HsVersions.h" import Language.Haskell.Syntax.Expr +import Language.Haskell.Syntax.Pat -- friends: import GHC.Prelude diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 6efbfb860e..90048eb4e9 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -628,7 +628,7 @@ conPatNeedsParens p = go go (InfixCon {}) = p >= opPrec -- type args should be empty in this case go (RecCon {}) = False --- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and +-- | @'parenthesizeLPat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: IsPass p => PprPrec diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index a23c1a1868..3e9f27d044 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -249,7 +249,8 @@ mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField, + Anno (IdGhcP p) ~ SrcSpanAnnN) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) @@ -1158,7 +1159,6 @@ collectStmtBinders flag = \case ----------------- Patterns -------------------------- - collectPatBinders :: CollectPass p => CollectFlag p @@ -1173,7 +1173,6 @@ collectPatsBinders -> [IdP p] collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats - ------------- -- | Indicate if evidence binders have to be collected. diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 356a728b23..d0c27ac25b 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2778,7 +2778,7 @@ aexp :: { ECP } unECP $2 >>= \ $2 -> mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] } - | '\\' apat apats '->' exp + | '\\' typats apats '->' exp { ECP $ unECP $5 >>= \ $5 -> mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource @@ -2786,7 +2786,7 @@ aexp :: { ECP } [reLocA $ sLLlA $1 $> $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs , m_ctxt = LambdaExpr - , m_pats = $2:$3 + , m_pats = $3 , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) noCom) }])) } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> @@ -3284,6 +3284,13 @@ apats :: { [LPat GhcPs] } : apat apats { $1 : $2 } | {- empty -} { [] } +typat :: { LHsTyVarBndr Specificity GhcPs } + : PREFIX_AT tv_bndr { $2 } + +typats :: { [LHsTyVarBndr Specificity GhcPs] } + : typat typats { $1 : $2 } + | {- empty -} { [] } + ----------------------------------------------------------------------------- -- Statement sequences diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index 83812f7673..e3f7e869da 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -401,7 +401,6 @@ data Hint | SuggestLetInDo | SuggestPatternSynonyms | SuggestInfixBindMaybeAtPat !RdrName - | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors data LexErrKind diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 7b9f2e64a0..cf8ae06744 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -616,8 +616,6 @@ pp_hint = \case $$ if opIsAt fun then perhaps_as_pat else empty - TypeApplicationsInPatternsOnlyDataCons -> - text "Type applications in patterns are only allowed on data constructors." perhaps_as_pat :: SDoc perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 2686bc151b..29deab034a 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -58,6 +58,7 @@ module GHC.Parser.PostProcess ( checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_hints, + checkTyVars, checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, @@ -1091,10 +1092,7 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args { pat_con_ext = noAnn -- AZ: where should this come from? , pat_con = L ln c , pat_args = PrefixCon tyargs args - } - | not (null tyargs) = - add_hint TypeApplicationsInPatternsOnlyDataCons $ - patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) + } | not (null args) && patIsRec c = add_hint SuggestRecursiveDo $ patFail (locA l) (ppr e) @@ -1106,6 +1104,9 @@ checkPat loc (L _ (PatBuilderApp f e)) [] args = do checkPat loc (L l e) [] [] = do p <- checkAPat loc e return (L l p) +checkPat loc e tyargs args + | not (null tyargs), (_:tyargs') <- tyargs = + checkPat loc e tyargs' args checkPat loc e _ _ = patFail (locA loc) (ppr e) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 7ab31322c9..a22ad04869 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -257,7 +257,6 @@ tc_cmd env (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpanA mtch_loc $ tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 5a7fb93f48..53b2e9b232 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -71,7 +71,9 @@ module GHC.Tc.Gen.HsType ( HoleMode(..), -- Error messages - funAppCtxt, addTyConFlavCtxt + funAppCtxt, addTyConFlavCtxt, + + tcTyVar, typeLevelMode ) where #include "HsVersions.h" diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 77c436c912..5756556682 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -950,7 +950,8 @@ cvtl e = wrapLA (cvt e) -- oddities that can result from zero-argument -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; let pats = map (parenthesizePat appPrec) ps' + ; let pats' = ps' + ; let pats = map (parenthesizePat appPrec) pats' ; th_origin <- getOrigin ; return $ HsLam noExtField (mkMatchGroup th_origin (noLocA [mkSimpleMatch LambdaExpr -- cgit v1.2.1