diff options
Diffstat (limited to 'compiler/GHC/Parser')
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 23 |
3 files changed, 21 insertions, 9 deletions
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 138a24ccd5..59edbff669 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -177,6 +177,8 @@ instance Diagnostic PsMessage where -> mkSimpleDecorated $ text "Illegal lambda-case" PsErrEmptyLambda -> mkSimpleDecorated $ text "A lambda requires at least one parameter" + PsErrorIllegalTypeArguments + -> mkSimpleDecorated $ text "Type variable arguments after ordinary patterns are not allowed yet" PsErrLinearFunction -> mkSimpleDecorated $ text "Illegal use of linear functions" PsErrOverloadedRecordUpdateNotEnabled @@ -598,6 +600,7 @@ instance Diagnostic PsMessage where PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag PsErrInvalidCApiImport {} -> ErrorWithoutFlag + PsErrorIllegalTypeArguments -> ErrorWithoutFlag diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m @@ -757,6 +760,7 @@ instance Diagnostic PsMessage where PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints PsErrInvalidCApiImport {} -> noHints + PsErrorIllegalTypeArguments -> noHints psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index d39048c441..01168441c9 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -144,6 +144,9 @@ data PsMessage -- | A lambda requires at least one parameter | PsErrEmptyLambda + -- | Type variable arguments after ordinary patterns are not allowed yet + | PsErrorIllegalTypeArguments + -- | Underscores in literals without the extension enabled | PsErrNumUnderscores !NumUnderscoreReason diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index e553348ea7..79855ddb40 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -655,17 +655,18 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = wrongNameBindingErr (locA loc) decl ; match <- case details of PrefixCon _ pats -> return $ Match { m_ext = noAnn - , m_ctxt = ctxt, m_pats = pats + , m_ctxt = ctxt + , m_pats = (\pat -> L loc (VisPat noExtField pat)) <$> pats , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln , mc_fixity = Prefix , mc_strictness = NoSrcStrict } - InfixCon p1 p2 -> return $ Match { m_ext = noAnn - , m_ctxt = ctxt - , m_pats = [p1, p2] - , m_grhss = rhs } + InfixCon p1@(L l1 _) p2@(L l2 _) -> return $ Match { m_ext = noAnn + , m_ctxt = ctxt + , m_pats = [(L l1 (VisPat noExtField p1)), (L l2 (VisPat noExtField p2))] + , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln , mc_fixity = Infix @@ -1121,6 +1122,11 @@ checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkL checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] +checkLamPat :: LocatedA (PatBuilder GhcPs) -> PV (LMatchPat GhcPs) +checkLamPat (L l (PatBuilderAppType _ (HsPS {hsps_body = L _ (HsTyVar _ NotPromoted c)}))) = + return $ (L l (InvisTyVarPat EpAnnNotUsed c)) +checkLamPat e@(L l _) = (\pat -> L l (VisPat noExtField pat)) <$> checkPat l e [] [] + checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args @@ -1129,8 +1135,6 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args , pat_con = L ln c , pat_args = PrefixCon tyargs args } - | not (null tyargs) = - patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs | (not (null args) && patIsRec c) = do ctx <- askParseContext patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx @@ -1246,7 +1250,7 @@ checkFunBind :: SrcStrictness -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) checkFunBind strictness locF ann fun is_infix pats (L _ grhss) - = do ps <- runPV_details extraDetails (mapM checkLPat pats) + = do ps <- runPV_details extraDetails (mapM checkLamPat pats) let match_span = noAnnSrcSpan $ locF cs <- getCommentsFor locF return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) @@ -1289,7 +1293,7 @@ checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v)))) , mc_fixity = Prefix , mc_strictness = SrcStrict } , m_pats = [] - , m_grhss = grhss } + , m_grhss = grhss } checkPatBind loc annsIn lhs (L _ grhss) = do cs <- getCommentsFor loc @@ -1346,6 +1350,7 @@ isFunLhs e = go e [] [] [] op_app = L loc (PatBuilderOpApp k (L loc' op) r (EpAnn loca (reverse ops++cps) cs)) _ -> return Nothing } + go (L _ (PatBuilderAppType pat _)) es ann cps = go pat es ann cps go _ _ _ _ = return Nothing mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs |