diff options
| author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2019-04-23 21:21:33 +0300 |
|---|---|---|
| committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2019-04-29 16:37:00 +0300 |
| commit | 0a18bd64ce54ea1c787366e3d38fc2f1a333f58c (patch) | |
| tree | 2c9c5be428095a63ccef1f38ed28554dadd28639 | |
| parent | 0040af598865733e6565530f4b036e11563976fc (diff) | |
| download | haskell-wip/pat-builder-tagless.tar.gz | |
Pattern/expression ambiguity resolutionwip/pat-builder-tagless
This patch removes 'EWildPat', 'EAsPat', 'EViewPat', and 'ELazyPat'
from 'HsExpr' by using the ambiguity resolution system introduced
earlier for the command/expression ambiguity.
Problem: there are places in the grammar where we do not know whether we
are parsing an expression or a pattern, for example:
do { Con a b <- x } -- 'Con a b' is a pattern
do { Con a b } -- 'Con a b' is an expression
Until we encounter binding syntax (<-) we don't know whether to parse
'Con a b' as an expression or a pattern.
The old solution was to parse as HsExpr always, and rejig later:
checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
This meant polluting 'HsExpr' with pattern-related constructors. In
other words, limitations of the parser were affecting the AST, and all
other code (the renamer, the typechecker) had to deal with these extra
constructors.
We fix this abstraction leak by parsing into an overloaded
representation:
class DisambECP b where ...
newtype ECP = ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
See Note [Ambiguous syntactic categories] for details.
Now the intricacies of parsing have no effect on the hsSyn AST when it
comes to the expression/pattern ambiguity.
48 files changed, 1007 insertions, 602 deletions
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 89ca815ed5..12b0c838a6 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" -ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" -ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" -ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" -ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 2ab2acbe3f..d86077ea27 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -870,18 +870,6 @@ instance ( a ~ GhcPass p HsSpliceE _ x -> [ toHie $ L mspan x ] - EWildPat _ -> [] - EAsPat _ a b -> - [ toHie $ C Use a - , toHie b - ] - EViewPat _ a b -> - [ toHie a - , toHie b - ] - ELazyPat _ a -> - [ toHie a - ] XExpr _ -> [] instance ( a ~ GhcPass p diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index b86f4a147d..9052855c69 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -625,32 +625,6 @@ data HsExpr p (LHsExpr p) --------------------------------------- - -- These constructors only appear temporarily in the parser. - -- The renamer translates them into the Right Thing. - - | EWildPat (XEWildPat p) -- wildcard - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (XEAsPat p) - (Located (IdP p)) -- as pattern - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (XEViewPat p) - (LHsExpr p) -- view pattern - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern - - - --------------------------------------- -- Finally, HsWrap appears only in typechecker output -- The contained Expr is *NOT* itself an HsWrap. -- See Note [Detecting forced eta expansion] in DsExpr. This invariant @@ -761,10 +735,6 @@ type instance XStatic GhcTc = NameSet type instance XTick (GhcPass _) = NoExt type instance XBinTick (GhcPass _) = NoExt type instance XTickPragma (GhcPass _) = NoExt -type instance XEWildPat (GhcPass _) = NoExt -type instance XEAsPat (GhcPass _) = NoExt -type instance XEViewPat (GhcPass _) = NoExt -type instance XELazyPat (GhcPass _) = NoExt type instance XWrap (GhcPass _) = NoExt type instance XXExpr (GhcPass _) = NoExt @@ -924,21 +894,12 @@ ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr (OpApp _ e1 op e2) - | Just pp_op <- should_print_infix (unLoc op) + | Just pp_op <- ppr_infix_expr (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where - should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar _ h@TrueExprHole{}) - = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix (EWildPat _) = Just (text "`_`") - should_print_infix (HsWrap _ _ e) = should_print_infix e - should_print_infix _ = Nothing - pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear @@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2) ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e ppr_expr (SectionL _ expr op) - = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly (conLikeName c) - HsUnboundVar _ h@TrueExprHole{} - -> pp_infixly (unboundVarOcc h) - _ -> pp_prefixly + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly v = (sep [pp_expr, v]) ppr_expr (SectionR _ op expr) - = case unLoc op of - HsVar _ (L _ v) -> pp_infixly v - HsConLikeOut _ c -> pp_infixly (conLikeName c) - HsUnboundVar _ h@TrueExprHole{} - -> pp_infixly (unboundVarOcc h) - _ -> pp_prefixly + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) - pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc - pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly v = sep [v, pp_expr] ppr_expr (ExplicitTuple _ exprs boxity) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) @@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (EWildPat _) = char '_' -ppr_expr (ELazyPat _ e) = char '~' <> ppr e -ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e -ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e - ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written @@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = ppr x +ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) +ppr_infix_expr (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) +ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) +ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) +ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e +ppr_infix_expr _ = Nothing + ppr_apps :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] @@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go go (RecordUpd{}) = False go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False - go (EWildPat{}) = False - go (ELazyPat{}) = False - go (EAsPat{}) = False - go (EViewPat{}) = True go (HsSCC{}) = p >= appPrec go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 1bebec0896..1d14da20b9 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -539,10 +539,6 @@ type family XStatic x type family XTick x type family XBinTick x type family XTickPragma x -type family XEWildPat x -type family XEAsPat x -type family XEViewPat x -type family XELazyPat x type family XWrap x type family XXExpr x @@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) = , c (XTick x) , c (XBinTick x) , c (XTickPragma x) - , c (XEWildPat x) - , c (XEAsPat x) - , c (XEViewPat x) - , c (XELazyPat x) , c (XWrap x) , c (XXExpr x) ) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c23c320ac9..3c1ea8cc7d 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -58,7 +58,6 @@ module Lexer ( activeContext, nextIsEOF, getLexState, popLexState, pushLexState, ExtBits(..), - addWarning, lexTokenStream, AddAnn,mkParensApiAnn, commentToAnnotation @@ -2493,6 +2492,9 @@ class Monad m => MonadP m where -- more than one parse error per file. -- addError :: SrcSpan -> SDoc -> m () + -- | Add a warning to the accumulator. + -- Use 'getMessages' to get the accumulated warnings. + addWarning :: WarningFlag -> SrcSpan -> SDoc -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state. addFatalError :: SrcSpan -> SDoc -> m a @@ -2515,6 +2517,16 @@ instance MonadP P where es' = es `snocBag` errormsg in (ws, es') in POk s{messages=m'} () + addWarning option srcspan warning + = P $ \s@PState{messages=m, options=o} -> + let + m' d = + let (ws, es) = m d + warning' = makeIntoWarning (Reason option) $ + mkWarnMsg d srcspan alwaysQualify warning + ws' = if warnopt option o then ws `snocBag` warning' else ws + in (ws', es) + in POk s{messages=m'} () addFatalError span msg = addError span msg >> P PFailed getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) @@ -2524,20 +2536,6 @@ instance MonadP P where addAnnotationOnly l a v allocateComments l --- | Add a warning to the accumulator. --- Use 'getMessages' to get the accumulated warnings. -addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () -addWarning option srcspan warning - = P $ \s@PState{messages=m, options=o} -> - let - m' d = - let (ws, es) = m d - warning' = makeIntoWarning (Reason option) $ - mkWarnMsg d srcspan alwaysQualify warning - ws' = if warnopt option o then ws `snocBag` warning' else ws - in (ws', es) - in POk s{messages=m'} () - addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4bc3fa9ad0..80e197e039 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1064,7 +1064,8 @@ topdecl :: { LHsDecl GhcPs } -- The $(..) form is one possible form of infixexp -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp_top { sLL $1 $> $ mkSpliceDecl $1 } + | infixexp_top {% runECP_P $1 >>= \ $1 -> + return $ sLL $1 $> $ mkSpliceDecl $1 } -- Type classes -- @@ -1509,7 +1510,7 @@ decl_cls : at_decl_cls { $1 } -- A 'default' signature used with the generic-programming extension | 'default' infixexp '::' sigtypedoc - {% runExpCmdP $2 >>= \ $2 -> + {% runECP_P $2 >>= \ $2 -> do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) @@ -1649,8 +1650,8 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp - {%runExpCmdP $4 >>= \ $4 -> - runExpCmdP $6 >>= \ $6 -> + {%runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> ams (sLL $1 $> $ HsRule { rd_ext = noExt , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive @@ -1760,19 +1761,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } ----------------------------------------------------------------------------- -- Annotations annotation :: { LHsDecl GhcPs } - : '{-# ANN' name_var aexp '#-}' {% runExpCmdP $3 >>= \ $3 -> + : '{-# ANN' name_var aexp '#-}' {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } - | '{-# ANN' 'type' tycon aexp '#-}' {% runExpCmdP $4 >>= \ $4 -> + | '{-# ANN' 'type' tycon aexp '#-}' {% runECP_P $4 >>= \ $4 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (TypeAnnProvenance $3) $4)) [mo $1,mj AnnType $2,mc $5] } - | '{-# ANN' 'module' aexp '#-}' {% runExpCmdP $3 >>= \ $3 -> + | '{-# ANN' 'module' aexp '#-}' {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) ModuleAnnProvenance $3)) @@ -2393,8 +2394,8 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% runExpCmdP $2 >>= \ $2 -> - do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) + | '!' aexp rhs {% runECP_P $2 >>= \ $2 -> + do { let { e = patBuilderBang (getLoc $1) $2 ; l = comb2 $1 $> }; (ann, r) <- checkValDef SrcStrict e Nothing $3 ; runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ; @@ -2410,7 +2411,8 @@ decl_no_th :: { LHsDecl GhcPs } _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; return $! (sL l $ ValD noExt r) } } - | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; + | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 -> + do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; let { l = comb2 $1 $> }; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note @@ -2434,7 +2436,7 @@ decl :: { LHsDecl GhcPs } | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } - : '=' exp wherebinds {% runExpCmdP $2 >>= \ $2 -> return $ + : '=' exp wherebinds {% runECP_P $2 >>= \ $2 -> return $ sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2) @@ -2448,7 +2450,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } | gdrh { sL1 $1 [$1] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% runExpCmdP $4 >>= \ $4 -> + : '|' guardquals '=' exp {% runECP_P $4 >>= \ $4 -> ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } @@ -2456,7 +2458,8 @@ sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp_top '::' sigtypedoc - {% do { v <- checkValSigLhs $1 + {% do { $1 <- runECP_P $1 + ; v <- checkValSigLhs $1 ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] ; return (sLL $1 $> $ SigD noExt $ TypeSig noExt [v] (mkLHsSigWcType $3))} } @@ -2548,84 +2551,90 @@ quasiquote :: { Located (HsSplice GhcPs) } ; quoterId = mkQual varName (qual, quoter) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -exp :: { ExpCmdP } - : infixexp '::' sigtype {% runExpCmdP $1 >>= \ $1 -> - fmap ecFromExp $ - ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3)) +exp :: { ECP } + : infixexp '::' sigtype { ECP $ + runECP_PV $1 >>= \ $1 -> + amms (mkHsTySigPV (comb2 $1 $>) $1 $3) [mu AnnDcolon $2] } - | infixexp '-<' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '-<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3 HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1 HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '-<<' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3 HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromCmd $ + | infixexp '>>-' exp {% runECP_P $1 >>= \ $1 -> + runECP_P $3 >>= \ $3 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1 HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } -infixexp :: { ExpCmdP } +infixexp :: { ECP } : exp10 { $1 } - | infixexp qop exp10 { ExpCmdP $ - runExpCmdPV $1 >>= \ $1 -> - runExpCmdPV $3 >>= \ $3 -> - ams (sLL $1 $> (ecOpApp $1 $2 $3)) + | infixexp qop exp10 { ECP $ + superInfixOp $ + $2 >>= \ $2 -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator -infixexp_top :: { LHsExpr GhcPs } - : exp10_top {% runExpCmdP $1 } +infixexp_top :: { ECP } + : exp10_top { $1 } | infixexp_top qop exp10_top - {% runExpCmdP $3 >>= \ $3 -> + { ECP $ + superInfixOp $ + $2 >>= \ $2 -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> do { when (srcSpanEnd (getLoc $2) == srcSpanStart (getLoc $3) - && checkIfBang $2) $ + && checkIfBang (unLoc $2)) $ warnSpaceAfterBang (comb2 $2 $3); - ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) [mj AnnVal $2] } } -exp10_top :: { ExpCmdP } - : '-' fexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) +exp10_top :: { ECP } + : '-' fexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] } - | hpc_annot exp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | hpc_annot exp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } - | '{-# CORE' STRING '#-}' exp {% runExpCmdP $4 >>= \ $4 -> - fmap ecFromExp $ + | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation | fexp { $1 } -exp10 :: { ExpCmdP } +exp10 :: { ECP } : exp10_top { $1 } - | scc_annot exp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | scc_annot exp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } @@ -2668,175 +2677,172 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In ))) } -fexp :: { ExpCmdP } - : fexp aexp {% runExpCmdP $2 >>= \ $2 -> - runPV (checkBlockArguments $2) >>= \_ -> - return $ ExpCmdP $ - runExpCmdPV $1 >>= \ $1 -> - checkBlockArguments $1 >>= \_ -> - return (sLL $1 $> (ecHsApp $1 $2)) } - | fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 -> - runPV (checkBlockArguments $1) >>= \_ -> - fmap ecFromExp $ +fexp :: { ECP } + : fexp aexp { ECP $ + superFunArg $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $2 >>= \ $2 -> + mkHsAppPV (comb2 $1 $>) $1 $2 } + | fexp TYPEAPP atype {% runECP_P $1 >>= \ $1 -> + runPV (checkExpBlockArguments $1) >>= \_ -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } - | 'static' aexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | 'static' aexp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsStatic noExt $2) [mj AnnStatic $1] } | aexp { $1 } -aexp :: { ExpCmdP } - : qvar '@' aexp {% runExpCmdP $3 >>= \ $3 -> - fmap ecFromExp $ - ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } +aexp :: { ECP } + : qvar '@' aexp { ECP $ + runECP_PV $3 >>= \ $3 -> + amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } + | '~' aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } | '\\' apat apats '->' exp - { ExpCmdP $ - runExpCmdPV $5 >>= \ $5 -> - ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource + { ECP $ + runECP_PV $5 >>= \ $5 -> + amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource [sLL $1 $> $ Match { m_ext = noExt , m_ctxt = LambdaExpr , m_pats = $2:$3 , m_grhss = unguardedGRHSs $5 }])) [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp { ExpCmdP $ - runExpCmdPV $4 >>= \ $4 -> - ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4) + | 'let' binds 'in' exp { ECP $ + runECP_PV $4 >>= \ $4 -> + amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } | '\\' 'lcase' altslist {% runPV $3 >>= \ $3 -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (sLL $1 $> $ HsLamCase noExt (mkMatchGroup FromSource (snd $ unLoc $3))) (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% runExpCmdP $2 >>= \ $2 -> - return $ ExpCmdP $ - runExpCmdPV $5 >>= \ $5 -> - runExpCmdPV $8 >>= \ $8 -> - checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ ecHsIf $2 $5 $8) + {% runECP_P $2 >>= \ $2 -> + return $ ECP $ + runECP_PV $5 >>= \ $5 -> + runECP_PV $8 >>= \ $8 -> + amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8) (mj AnnIf $1:mj AnnThen $4 :mj AnnElse $7 :(map (\l -> mj AnnSemi l) (fst $3)) ++(map (\l -> mj AnnSemi l) (fst $6))) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (sLL $1 $> $ HsMultiIf noExt (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% runExpCmdP $2 >>= \ $2 -> - return $ ExpCmdP $ + | 'case' exp 'of' altslist {% runECP_P $2 >>= \ $2 -> + return $ ECP $ $4 >>= \ $4 -> - ams (cL (comb3 $1 $3 $4) $ - ecHsCase $2 (mkMatchGroup + amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | 'do' stmtlist { ExpCmdP $ + | 'do' stmtlist { ECP $ $2 >>= \ $2 -> - ams (cL (comb2 $1 $2) - (ecHsDo (mapLoc snd $2))) + amms (mkHsDoPV (comb2 $1 $2) (mapLoc snd $2)) (mj AnnDo $1:(fst $ unLoc $2)) } | 'mdo' stmtlist {% runPV $2 >>= \ $2 -> - fmap ecFromExp $ + fmap ecpFromExp $ ams (cL (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp - {% (checkPattern <=< runExpCmdP) $2 >>= \ p -> - runExpCmdP $4 >>= \ $4@cmd -> - fmap ecFromExp $ + {% (checkPattern <=< runECP_P) $2 >>= \ p -> + runECP_P $4 >>= \ $4@cmd -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } | aexp1 { $1 } -aexp1 :: { ExpCmdP } - : aexp1 '{' fbinds '}' {% runExpCmdP $1 >>= \ $1 -> - do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - (snd $3) - ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3)) - ; fmap ecFromExp $ - checkRecordSyntax (sLL $1 $> r) }} +aexp1 :: { ECP } + : aexp1 '{' fbinds '}' { ECP $ + runECP_PV $1 >>= \ $1 -> + $3 >>= \ $3 -> + amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) + (moc $2:mcc $4:(fst $3)) } | aexp2 { $1 } -aexp2 :: { ExpCmdP } - : qvar { ecFromExp $ sL1 $1 (HsVar noExt $! $1) } - | qcon { ecFromExp $ sL1 $1 (HsVar noExt $! $1) } - | ipvar { ecFromExp $ sL1 $1 (HsIPVar noExt $! unLoc $1) } - | overloaded_label { ecFromExp $ sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } - | literal { ecFromExp $ sL1 $1 (HsLit noExt $! unLoc $1) } +aexp2 :: { ECP } + : qvar { ECP $ mkHsVarPV $! $1 } + | qcon { ECP $ mkHsVarPV $! $1 } + | ipvar { ecpFromExp $ sL1 $1 (HsIPVar noExt $! unLoc $1) } + | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } + | literal { ECP $ mkHsLitPV $! $1 } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) noExt) } - | INTEGER { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } - | RATIONAL { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } + | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } + | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' { ExpCmdP $ - runExpCmdPV $2 >>= \ $2 -> - ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] } - | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) - ; fmap ecFromExp $ - ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - - | '(#' texp '#)' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ - ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2) - (Present noExt $2)] Unboxed)) - [mo $1,mc $3] } - | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) - ; fmap ecFromExp $ - ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } - - | '[' list ']' {% fmap ecFromExp $ ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } - | '_' { ecFromExp $ sL1 $1 $ EWildPat noExt } + | '(' texp ')' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] } + | '(' tup_exprs ')' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) + ((mop $1:fst $2) ++ [mcp $3]) } + + | '(#' texp '#)' { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)])) + [mo $1,mc $3] } + | '(#' tup_exprs '#)' { ECP $ + $2 >>= \ $2 -> + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2)) + ((mo $1:fst $2) ++ [mc $3]) } + + | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] } + | '_' { ECP $ mkHsWildCardPV (getLoc $1) } -- Template Haskell Extension - | splice_exp { ecFromExp $1 } + | splice_untyped { ECP $ mkHsSplicePV $1 } + | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExt) $1 } - | SIMPLEQUOTE qvar {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% fmap ecFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } - | '[|' exp '|]' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | '[|' exp '|]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromExp $ + | '[||' exp '||]' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ktype '|]' {% fmap ecFromExp $ + | '[t|' ktype '|]' {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } - | '[p|' infixexp '|]' {% (checkPattern <=< runExpCmdP) $2 >>= \p -> - fmap ecFromExp $ + | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p -> + fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% fmap ecFromExp $ + | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { ecFromExp $ sL1 $1 (HsSpliceE noExt (unLoc $1)) } + | quasiquote { ECP $ mkHsSplicePV $1 } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% runExpCmdP $2 >>= \ $2 -> - fmap ecFromCmd $ + | '(|' aexp2 cmdargs '|)' {% runECP_P $2 >>= \ $2 -> + fmap ecpFromCmd $ ams (sLL $1 $> $ HsCmdArrForm noExt $2 Prefix Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } @@ -2850,7 +2856,7 @@ splice_untyped :: { Located (HsSplice GhcPs) } (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } - | '$(' exp ')' {% runExpCmdP $2 >>= \ $2 -> + | '$(' exp ')' {% runECP_P $2 >>= \ $2 -> ams (sLL $1 $> $ mkUntypedSplice HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } @@ -2859,7 +2865,7 @@ splice_typed :: { Located (HsSplice GhcPs) } (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% runExpCmdP $2 >>= \ $2 -> + | '$$(' exp ')' {% runECP_P $2 >>= \ $2 -> ams (sLL $1 $> $ mkTypedSplice HasParens $2) [mj AnnOpenPTE $1,mj AnnCloseP $3] } @@ -2868,7 +2874,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } | {- empty -} { [] } acmd :: { LHsCmdTop GhcPs } - : aexp2 {% runExpCmdP $1 >>= \ cmd -> + : aexp2 {% runECP_P $1 >>= \ cmd -> return (sL1 cmd $ HsCmdTop noExt cmd) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } @@ -2886,7 +2892,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] } -- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas -texp :: { ExpCmdP } +texp :: { ECP } : exp { $1 } -- Note [Parsing sections] @@ -2900,98 +2906,112 @@ texp :: { ExpCmdP } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop {% runExpCmdP $1 >>= \ $1 -> - return $ ecFromExp $ + | infixexp qop {% runECP_P $1 >>= \ $1 -> + runPV $2 >>= \ $2 -> + return $ ecpFromExp $ sLL $1 $> $ SectionL noExt $1 $2 } - | qopm infixexp {% runExpCmdP $2 >>= \ $2 -> - return $ ecFromExp $ - sLL $1 $> $ SectionR noExt $1 $2 } + | qopm infixexp { ECP $ + superInfixOp $ + runECP_PV $2 >>= \ $2 -> + $1 >>= \ $1 -> + mkHsSectionR_PV (comb2 $1 $>) $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - fmap ecFromExp $ - ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } + | exp '->' texp { ECP $ + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. -tup_exprs :: { ([AddAnn],SumOrTuple) } +tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } : texp commas_tup_tail - {% runExpCmdP $1 >>= \ $1 -> + { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } } - | texp bars {% runExpCmdP $1 >>= \ $1 -> return $ + | texp bars { runECP_PV $1 >>= \ $1 -> return $ (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } | commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } } | bars texp bars0 - {% runExpCmdP $2 >>= \ $2 -> return $ + { runECP_PV $2 >>= \ $2 -> return $ (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { (SrcSpan,[LHsTupArg GhcPs]) } +commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) } commas_tup_tail : commas tup_tail - {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) + { $2 >>= \ $2 -> + do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma -tup_tail :: { [LHsTupArg GhcPs] } - : texp commas_tup_tail {% runExpCmdP $1 >>= \ $1 -> - addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Present noExt $1)) : snd $2) } - | texp {% runExpCmdP $1 >>= \ $1 -> - return [cL (gl $1) (Present noExt $1)] } - | {- empty -} { [noLoc missingTupArg] } +tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } + : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> + $2 >>= \ $2 -> + addAnnotation (gl $1) AnnComma (fst $2) >> + return ((cL (gl $1) (Just $1)) : snd $2) } + | texp { runECP_PV $1 >>= \ $1 -> + return [cL (gl $1) (Just $1)] } + | {- empty -} { return [noLoc Nothing] } ----------------------------------------------------------------------------- -- List expressions -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. -list :: { ([AddAnn],HsExpr GhcPs) } - : texp {% runExpCmdP $1 >>= \ $1 -> - return ([],ExplicitList noExt Nothing [$1]) } - | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } - | texp '..' {% runExpCmdP $1 >>= \ $1 -> - return ([mj AnnDotdot $2], - ArithSeq noExt Nothing (From $1)) } - | texp ',' exp '..' {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - return ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThen $1 $3)) } - | texp '..' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - return ([mj AnnDotdot $2], - ArithSeq noExt Nothing - (FromTo $1 $3)) } - | texp ',' exp '..' exp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> - runExpCmdP $5 >>= \ $5 -> - return ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThenTo $1 $3 $5)) } +list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } + : texp { \loc -> runECP_PV $1 >>= \ $1 -> + mkHsExplicitListPV loc [$1] } + | lexps { \loc -> $1 >>= \ $1 -> + mkHsExplicitListPV loc (reverse $1) } + | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> + ams (cL loc $ ArithSeq noExt Nothing (From $1)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (cL loc $ ArithSeq noExt Nothing (FromThen $1 $3)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } + | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + ams (cL loc $ ArithSeq noExt Nothing (FromTo $1 $3)) + [mj AnnDotdot $2] + >>= ecpFromExp' } + | texp ',' exp '..' exp { \loc -> + runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + runECP_PV $5 >>= \ $5 -> + ams (cL loc $ ArithSeq noExt Nothing (FromThenTo $1 $3 $5)) + [mj AnnComma $2,mj AnnDotdot $4] + >>= ecpFromExp' } | texp '|' flattenedpquals - {% checkMonadComp >>= \ ctxt -> - runExpCmdP $1 >>= \ $1 -> - return ([mj AnnVbar $2], - mkHsComp ctxt (unLoc $3) $1) } - -lexps :: { Located [LHsExpr GhcPs] } - : lexps ',' texp {% runExpCmdP $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) + { \loc -> + checkMonadComp >>= \ ctxt -> + runECP_PV $1 >>= \ $1 -> + ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) + [mj AnnVbar $2] + >>= ecpFromExp' } + +lexps :: { forall b. DisambECP b => PV [Located b] } + : lexps ',' texp { $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> + addAnnotation (gl $ head $ $1) AnnComma (gl $2) >> - return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } - | texp ',' texp {% runExpCmdP $1 >>= \ $1 -> - runExpCmdP $3 >>= \ $3 -> + return (((:) $! $3) $! $1) } + | texp ',' texp { runECP_PV $1 >>= \ $1 -> + runECP_PV $3 >>= \ $3 -> addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> [$3,$1]) } + return [$3,$1] } ----------------------------------------------------------------------------- -- List Comprehensions @@ -3039,20 +3059,20 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* - : 'then' exp {% runExpCmdP $2 >>= \ $2 -> return $ + : 'then' exp {% runECP_P $2 >>= \ $2 -> return $ sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } - | 'then' exp 'by' exp {% runExpCmdP $2 >>= \ $2 -> - runExpCmdP $4 >>= \ $4 -> + | 'then' exp 'by' exp {% runECP_P $2 >>= \ $2 -> + runECP_P $4 >>= \ $4 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3], \ss -> (mkTransformByStmt ss $2 $4)) } | 'then' 'group' 'using' exp - {% runExpCmdP $4 >>= \ $4 -> + {% runECP_P $4 >>= \ $4 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) } | 'then' 'group' 'by' exp 'using' exp - {% runExpCmdP $4 >>= \ $4 -> - runExpCmdP $6 >>= \ $6 -> + {% runECP_P $4 >>= \ $4 -> + runECP_P $6 >>= \ $6 -> return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) } @@ -3078,7 +3098,7 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : '{' alts '}' { $2 >>= \ $2 -> return $ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } @@ -3088,14 +3108,14 @@ altslist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Locate | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { return $ noLoc ([],[]) } -alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) ,snd $ unLoc $2) } -alts1 :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } +alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 ';' alt { $1 >>= \ $1 -> $3 >>= \ $3 -> if null (snd $ unLoc $1) @@ -3113,7 +3133,7 @@ alts1 :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located >> return (sLL $1 $> ([],snd $ unLoc $1))) } | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) } -alt :: { forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs))) } +alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) } : pat alt_rhs { $2 >>= \ $2 -> ams (sLL $1 $> (Match { m_ext = noExt , m_ctxt = CaseAlt @@ -3121,18 +3141,18 @@ alt :: { forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs))) } , m_grhss = snd $ unLoc $2 })) (fst $ unLoc $2)} -alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (b GhcPs)))) } +alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) } : ralt wherebinds { $1 >>= \alt -> return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) } -ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) } - : '->' exp { runExpCmdPV $2 >>= \ $2 -> +ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } + : '->' exp { runECP_PV $2 >>= \ $2 -> ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) [mu AnnRarrow $1] } | gdpats { $1 >>= \gdpats -> return $ sL1 gdpats (reverse (unLoc gdpats)) } -gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) } +gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } : gdpats gdpat { $1 >>= \gdpats -> $2 >>= \gdpat -> return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } @@ -3147,9 +3167,9 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } | gdpats close {% runPV $1 >>= \ $1 -> return $ sL1 $1 ([],unLoc $1) } -gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) } +gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } : '|' guardquals '->' exp - { runExpCmdPV $4 >>= \ $4 -> + { runECP_PV $4 >>= \ $4 -> ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } @@ -3158,28 +3178,24 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) } -- Bangs inside are parsed as infix operator applications, so that -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } -pat : exp {% (checkPattern <=< runExpCmdP) $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - amms (checkPattern (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) +pat : exp {% (checkPattern <=< runECP_P) $1 } + | '!' aexp {% runECP_P $2 >>= \ $2 -> + amms (checkPattern (patBuilderBang (getLoc $1) $2)) [mj AnnBang $1] } bindpat :: { LPat GhcPs } -bindpat : exp {% runExpCmdP $1 >>= \ $1 -> - -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn - checkPattern_msg (text "Possibly caused by a missing 'do'?") $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn +bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn + checkPattern_msg (text "Possibly caused by a missing 'do'?") + (runECP_PV $1) } + | '!' aexp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn amms (checkPattern_msg (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (patBuilderBang (getLoc $1) `fmap` runECP_PV $2)) [mj AnnBang $1] } apat :: { LPat GhcPs } -apat : aexp {% (checkPattern <=< runExpCmdP) $1 } - | '!' aexp {% runExpCmdP $2 >>= \ $2 -> - amms (checkPattern - (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) +apat : aexp {% (checkPattern <=< runECP_P) $1 } + | '!' aexp {% runECP_P $2 >>= \ $2 -> + amms (checkPattern (patBuilderBang (getLoc $1) $2)) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -3189,7 +3205,7 @@ apats :: { [LPat GhcPs] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) } +stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } : '{' stmts '}' { $2 >>= \ $2 -> return $ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? @@ -3203,7 +3219,7 @@ stmtlist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) } +stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } : stmts ';' stmt { $1 >>= \ $1 -> $3 >>= \ $3 -> if null (snd $ unLoc $1) @@ -3236,17 +3252,17 @@ maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } : stmt {% runPV $1 } -stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } +stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) (mj AnnRec $1:(fst $ unLoc $2)) } -qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } - : bindpat '<-' exp { runExpCmdPV $3 >>= \ $3 -> +qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + : bindpat '<-' exp { runECP_PV $3 >>= \ $3 -> ams (sLL $1 $> $ mkBindStmt $1 $3) [mu AnnLarrow $2] } - | exp { runExpCmdPV $1 >>= \ $1 -> + | exp { runECP_PV $1 >>= \ $1 -> return $ sL1 $1 $ mkBodyStmt $1 } | 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2)) (mj AnnLet $1:(fst $ unLoc $2)) } @@ -3254,26 +3270,30 @@ qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } +fbinds :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } : fbinds1 { $1 } - | {- empty -} { ([],([], Nothing)) } + | {- empty -} { return ([],([], Nothing)) } -fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) } +fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) } : fbind ',' fbinds1 - {% addAnnotation (gl $1) AnnComma (gl $2) >> + { $1 >>= \ $1 -> + $3 >>= \ $3 -> + addAnnotation (gl $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } - | fbind { ([],([$1], Nothing)) } - | '..' { ([mj AnnDotdot $1],([], Just (getLoc $1))) } + | fbind { $1 >>= \ $1 -> + return ([],([$1], Nothing)) } + | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } -fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) } - : qvar '=' texp {% runExpCmdP $3 >>= \ $3 -> +fbind :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) } + : qvar '=' texp { runECP_PV $3 >>= \ $3 -> ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... - | qvar { sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True } + | qvar { placeHolderPunRhs >>= \rhs -> + return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -3291,7 +3311,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% runExpCmdP $3 >>= \ $3 -> +dbind : ipvar '=' exp {% runECP_P $3 >>= \ $3 -> ams (sLL $1 $> (IPBind noExt (Left $1) $3)) [mj AnnEqual $2] } @@ -3505,18 +3525,18 @@ varop :: { Located RdrName } [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } -qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvarop { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } | hole_op { $1 } -qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections + : qvaropm { mkHsVarOpPV $1 } + | qconop { mkHsConOpPV $1 } | hole_op { $1 } -hole_op :: { LHsExpr GhcPs } -- used in sections -hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt) +hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections +hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>)) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } @@ -3943,12 +3963,8 @@ hintExplicitForall tok = do where forallSymDoc = text (forallSym (isUnicode tok)) -checkIfBang :: LHsExpr GhcPs -> Bool -checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR -checkIfBang _ = False - -- | Warn about missing space after bang -warnSpaceAfterBang :: SrcSpan -> P () +warnSpaceAfterBang :: SrcSpan -> PV () warnSpaceAfterBang span = do bang_on <- getBit BangPatBit unless bang_on $ @@ -4048,7 +4064,7 @@ ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: HasSrcSpan a => P a -> [AddAnn] -> P a +amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a amms a bs = do { av@(dL->L l _) <- a ; addAnnsAt l bs ; return av } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f4b909b37a..8d15cb317b 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -13,8 +13,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module RdrHsSyn ( @@ -51,11 +49,11 @@ module RdrHsSyn ( -- Bunch of functions in the parser monad for -- checking and constructing values + checkExpBlockArguments, checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, - bang_RDR, isBangRdr, isTildeRdr, checkMonadComp, -- P (HsStmtContext RdrName) @@ -85,16 +83,19 @@ module RdrHsSyn ( warnStarIsType, failOpFewArgs, - SumOrTuple (..), mkSumOrTuple, + SumOrTuple (..), - -- Expression/command ambiguity resolution + -- Expression/command/pattern ambiguity resolution PV, runPV, - ExpCmdP(ExpCmdP, runExpCmdPV), - runExpCmdP, - ExpCmdI(..), - ecFromExp, - ecFromCmd, + ECP(ECP, runECP_PV), + runECP_P, + DisambInfixOp(..), + DisambECP(..), + ecpFromExp, + ecpFromCmd, + PatBuilder, + patBuilderBang, ) where @@ -911,7 +912,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" -checkRecordSyntax :: Outputable a => Located a -> P (Located a) +checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr@(dL->L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit unless allowed $ addError loc $ @@ -1056,117 +1057,80 @@ checkNoDocs msg ty = go ty -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs) +checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) -checkPattern_msg msg = runPV_msg msg . checkLPat +checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) -checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs) +checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(dL->L l _) = checkPat l e [] -checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] +checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args +checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ - patFail l e + patFail l (ppr e) checkPat loc e args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid -- non-bang-pattern parse of (C ! e) | Just (e', args') <- splitBang e = do { args'' <- mapM checkLPat args' ; checkPat loc e' (args'' ++ args) } -checkPat loc (dL->L _ (HsApp _ f e)) args +checkPat loc (dL->L _ (PatBuilderApp f e)) args = do p <- checkLPat e checkPat loc f (p : args) checkPat loc (dL->L _ e) [] = do p <- checkAPat loc e return (cL loc p) checkPat loc e _ - = patFail loc (unLoc e) + = patFail loc (ppr e) -checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs) +checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of - EWildPat _ -> return (WildPat noExt) - HsVar _ x -> return (VarPat noExt x) - HsLit _ (HsStringPrim _ _) -- (#13260) - -> addFatalError loc (text "Illegal unboxed string literal in pattern:" - $$ ppr e0) - - HsLit _ l -> return (LitPat noExt l) + PatBuilderPat p -> return p + PatBuilderVar x -> return (VarPat noExt x) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ - -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) + PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) - | bang == bang_RDR + PatBuilderBang lb e -- (! x) -> do { hintBangPat loc e0 ; e' <- checkLPat e ; addAnnotation loc AnnBang lb ; return (BangPat noExt e') } - ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt)) - EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n) - -- view pattern is well-formed if the pattern is - EViewPat _ expr patE -> checkLPat patE >>= - (return . (\p -> ViewPat noExt expr p)) - ExprWithTySig _ e t -> do e <- checkLPat e - return (SigPat noExt e t) - -- n+k patterns - OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) - (dL->L _ (HsVar _ (dL->L _ plus))) - (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + PatBuilderOpApp + (dL->L nloc (PatBuilderVar (dL->L _ n))) + (dL->L _ plus) + (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) - OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r - | isDataOcc (rdrNameOcc c) -> do + + PatBuilderOpApp l (dL->L cl c) r + | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r return (ConPatIn (cL cl c) (InfixCon l r)) - OpApp {} -> patFail loc e0 - - ExplicitList _ _ es -> do ps <- mapM checkLPat es - return (ListPat noExt ps) - - HsPar _ e -> checkLPat e >>= (return . (ParPat noExt)) - - ExplicitTuple _ es b - | all tupArgPresent es -> do ps <- mapM checkLPat - [e | (dL->L _ (Present _ e)) <- es] - return (TuplePat noExt ps b) - | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:" - $$ ppr e0) - - ExplicitSum _ alt arity expr -> do - p <- checkLPat expr - return (SumPat noExt p alt arity) - - RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } - -> do fs <- mapM checkPatField fs - return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE _ s | not (isTypedSplice s) - -> return (SplicePat noExt s) - _ -> patFail loc e0 + PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExt)) + _ -> patFail loc (ppr e0) -placeHolderPunRhs :: LHsExpr GhcPs +placeHolderPunRhs :: DisambECP b => PV (Located b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging -placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) +placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) -plus_RDR, bang_RDR, pun_RDR :: RdrName +plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack -bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") isBangRdr, isTildeRdr :: RdrName -> Bool @@ -1174,31 +1138,30 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" isBangRdr _ = False isTildeRdr = (==eqTyCon_RDR) -checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs) +checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (cL l (fld { hsRecFieldArg = p })) -patFail :: SrcSpan -> HsExpr GhcPs -> PV a +patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") - --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: SrcStrictness - -> LHsExpr GhcPs + -> Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkValDef _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding - = checkPatBind (cL (combineLocs lhs sig) - (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss + = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat + checkPatBind lhs' grhss checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -1206,14 +1169,16 @@ checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) Just (fun, is_infix, pats, ann) -> checkFunBind strictness ann (getLoc lhs) fun is_infix pats (cL l grhss) - Nothing -> checkPatBind lhs g } + Nothing -> do + lhs' <- checkPattern lhs + checkPatBind lhs' g } checkFunBind :: SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity - -> [LHsExpr GhcPs] + -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) @@ -1242,13 +1207,11 @@ makeFunBind fn ms fun_co_fn = idHsWrapper, fun_tick = [] } -checkPatBind :: LHsExpr GhcPs +checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind lhs (dL->L _ (_,grhss)) - = do { lhs <- checkPattern lhs - ; return ([],PatBind noExt lhs grhss - ([],[])) } + = return ([],PatBind noExt lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) @@ -1282,10 +1245,10 @@ checkValSigLhs lhs@(dL->L l _) default_RDR = mkUnqual varName (fsLit "default") pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse' +checkDoAndIfThenElse :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) => a -> Bool -> b -> Bool -> c -> PV () -checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit unless doAndIfThenElse $ do @@ -1303,20 +1266,21 @@ checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's -splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) +splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) - | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) +splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) + | isBangRdr (unLoc op) + = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) where - l' = combineLocs bang arg1 + l' = combineLocs op arg1 (arg1,argns) = split_bang r_arg [] - split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] -isFunLhs :: LHsExpr GhcPs - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) +isFunLhs :: Located (PatBuilder GhcPs) + -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1331,17 +1295,15 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (dL->L loc (HsVar _ (dL->L _ f))) es ann + go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann + go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) - (dL->L l (HsVar _ (L _ var))))) [] ann - | bang == bang_RDR - , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) + go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann + | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) -- For infix function defns, there should be only one infix *function* -- (though there may be infix *datacons* involved too). So we don't @@ -1356,7 +1318,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann + go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- getBit BangPatBit ; if bang_on then go e' (es' ++ es) ann @@ -1370,8 +1332,8 @@ isFunLhs e = go e [] [] Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = cL loc (OpApp noExt k - (cL loc' (HsVar noExt (cL loc' op))) r) + op_app = cL loc (PatBuilderOpApp k + (cL loc' op) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1856,7 +1818,7 @@ mergeDataCon all_xs = -- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- otherwise use the usual 'ListComp' context -checkMonadComp :: P (HsStmtContext Name) +checkMonadComp :: PV (HsStmtContext Name) checkMonadComp = do monadComprehensions <- getBit MonadComprehensionsBit return $ if monadComprehensions @@ -1864,96 +1826,373 @@ checkMonadComp = do else ListComp -- ------------------------------------------------------------------------- --- Expression/command ambiguity (arrow syntax). +-- Expression/command/pattern ambiguity. -- See Note [Ambiguous syntactic categories] -- --- ExpCmdP as defined is isomorphic to a pair of parsers: --- --- data ExpCmdP = ExpCmdP { expP :: PV (LHsExpr GhcPs) --- , cmdP :: PV (LHsCmd GhcPs) } --- -- See Note [Parser-Validator] -- See Note [Ambiguous syntactic categories] -newtype ExpCmdP = - ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) } +newtype ECP = + ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } -runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs)) -runExpCmdP p = runPV (runExpCmdPV p) +runECP_P :: DisambECP b => ECP -> P (Located b) +runECP_P p = runPV (runECP_PV p) -ecFromExp :: LHsExpr GhcPs -> ExpCmdP -ecFromExp a = ExpCmdP (ecFromExp' a) +ecpFromExp :: LHsExpr GhcPs -> ECP +ecpFromExp a = ECP (ecpFromExp' a) -ecFromCmd :: LHsCmd GhcPs -> ExpCmdP -ecFromCmd a = ExpCmdP (ecFromCmd' a) +ecpFromCmd :: LHsCmd GhcPs -> ECP +ecpFromCmd a = ECP (ecpFromCmd' a) +-- | Disambiguate infix operators. +-- See Note [Ambiguous syntactic categories] +class DisambInfixOp b where + checkIfBang :: b -> Bool + mkHsVarOpPV :: Located RdrName -> PV (Located b) + mkHsConOpPV :: Located RdrName -> PV (Located b) + mkHsInfixHolePV :: SrcSpan -> PV (Located b) + +instance p ~ GhcPs => DisambInfixOp (HsExpr p) where + checkIfBang (HsVar _ (unLoc -> op)) = isBangRdr op + checkIfBang _ = False + mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExt v) + mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExt v) + mkHsInfixHolePV l = return $ cL l hsHoleExpr + +instance DisambInfixOp RdrName where + checkIfBang = isBangRdr + mkHsConOpPV (dL->L l v) = return $ cL l v + mkHsVarOpPV (dL->L l v) = return $ cL l v + mkHsInfixHolePV l = + addFatalError l $ text "Invalid infix hole, expected an infix operator" + +-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are +-- parsing an expression, a command, or a pattern. -- See Note [Ambiguous syntactic categories] -class ExpCmdI b where +class b ~ (Body b) GhcPs => DisambECP b where + -- | See Note [Body in DisambECP] + type Body b :: * -> * -- | Return a command without ambiguity, or fail in a non-command context. - ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs)) + ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) -- | Return an expression without ambiguity, or fail in a non-expression context. - ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs)) + ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) -- | Disambiguate "\... -> ..." (lambda) - ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs + mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Disambiguate "let ... in ..." - ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs + mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) + -- | Infix operator representation + type InfixOp b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) -- | Disambiguate "f # x" (infix operator) - ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs + mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) -- | Disambiguate "case ... of ..." - ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) + -- | Function argument representation + type FunArg b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) -- | Disambiguate "f x" (function application) - ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs + mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) -- | Disambiguate "if ... then ... else ..." - ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> Located b + -> Bool -- semicolon? + -> Located b + -> PV (Located b) -- | Disambiguate "do { ... }" (do notation) - ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs + mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) -- | Disambiguate "( ... )" (parentheses) - ecHsPar :: Located (b GhcPs) -> b GhcPs - -- | Check if the argument requires -XBlockArguments. - checkBlockArguments :: Located (b GhcPs) -> PV () - -- | Check if -XDoAndIfThenElse is enabled. - checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs) - -> Bool -> Located (b GhcPs) -> PV () - -instance ExpCmdI HsCmd where - ecFromCmd' = return - ecFromExp' (dL-> L l e) = - addFatalError l $ - text "Parse error in command:" <+> ppr e - ecHsLam = HsCmdLam noExt - ecHsLet = HsCmdLet noExt - ecOpApp c1 op c2 = - let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in - HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] - ecHsCase = HsCmdCase noExt - ecHsApp = HsCmdApp noExt - ecHsIf = mkHsCmdIf - ecHsDo = HsCmdDo noExt - ecHsPar = HsCmdPar noExt - checkBlockArguments = checkCmdBlockArguments - checkDoAndIfThenElse = checkDoAndIfThenElse' - -instance ExpCmdI HsExpr where - ecFromCmd' (dL -> L l c) = do + mkHsParPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate a variable "f" or a data constructor "MkF". + mkHsVarPV :: Located RdrName -> PV (Located b) + -- | Disambiguate a monomorphic literal + mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) + -- | Disambiguate an overloaded literal + mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) + -- | Disambiguate a wildcard + mkHsWildCardPV :: SrcSpan -> PV (Located b) + -- | Disambiguate "a :: t" (type annotation) + mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + -- | Disambiguate "[a,b,c]" (list syntax) + mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) + -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) + mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) + -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) + mkHsRecordPV :: + SrcSpan -> + SrcSpan -> + Located b -> + ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> + PV (Located b) + -- | Disambiguate "-a" (negation) + mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate "(# a)" (right operator section) + mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) + -- | Disambiguate "(a -> b)" (view pattern) + mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) + -- | Disambiguate "a@b" (as-pattern) + mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) + -- | Disambiguate "~a" (lazy pattern) + mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate tuple sections and unboxed sums + mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) + +{- Note [UndecidableSuperClasses for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Assume we have a class C with an associated type T: + + class C a where + type T a + ... + +If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: + + {-# LANGUAGE UndecidableSuperClasses #-} + class C (T a) => C a where + type T a + ... + +Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes +making GHC loop. The workaround is to bring this constraint into scope +manually with a helper method: + + class C a where + type T a + superT :: (C (T a) => r) -> r + +In order to avoid ambiguous types, 'r' must mention 'a'. + +For consistency, we use this approach for all constraints on associated types, +even when -XUndecidableSuperClasses are not required. +-} + +{- Note [Body in DisambECP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that +require their argument to take a form of (body GhcPs) for some (body :: * -> +*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the +superclass constraints of DisambECP. + +The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop +this requirement. It is possible and would allow removing the type index of +PatBuilder, but leads to worse type inference, breaking some code in the +typechecker. +-} + +instance p ~ GhcPs => DisambECP (HsCmd p) where + type Body (HsCmd p) = HsCmd + ecpFromCmd' = return + ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) + mkHsLamPV l mg = return $ cL l (HsCmdLam noExt mg) + mkHsLetPV l bs e = return $ cL l (HsCmdLet noExt bs e) + type InfixOp (HsCmd p) = HsExpr p + superInfixOp m = m + mkHsOpAppPV l c1 op c2 = do + let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c + return $ cL l $ HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ cL l (HsCmdCase noExt c mg) + type FunArg (HsCmd p) = HsExpr p + superFunArg m = m + mkHsAppPV l c e = do + checkCmdBlockArguments c + checkExpBlockArguments e + return $ cL l (HsCmdApp noExt c e) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ cL l (mkHsCmdIf c a b) + mkHsDoPV l stmts = return $ cL l (HsCmdDo noExt stmts) + mkHsParPV l c = return $ cL l (HsCmdPar noExt c) + mkHsVarPV (dL->L l v) = cmdFail l (ppr v) + mkHsLitPV (dL->L l a) = cmdFail l (ppr a) + mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) + mkHsWildCardPV l = cmdFail l (text "_") + mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) + mkHsExplicitListPV l xs = cmdFail l $ + brackets (fsep (punctuate comma (map ppr xs))) + mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) + mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ + ppr a <+> ppr (mk_rec_fields fbinds ddLoc) + mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) + mkHsSectionR_PV l op c = cmdFail l $ + let pp_op = fromMaybe (panic "cannot print infix operator") + (ppr_infix_expr (unLoc op)) + in pp_op <> ppr c + mkHsViewPatPV l a b = cmdFail l $ + ppr a <+> text "->" <+> ppr b + mkHsAsPatPV l v c = cmdFail l $ + pprPrefixOcc (unLoc v) <> text "@" <> ppr c + mkHsLazyPatPV l c = cmdFail l $ + text "~" <> ppr c + mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) + +cmdFail :: SrcSpan -> SDoc -> PV a +cmdFail loc e = addFatalError loc $ + hang (text "Parse error in command:") 2 (ppr e) + +instance p ~ GhcPs => DisambECP (HsExpr p) where + type Body (HsExpr p) = HsExpr + ecpFromCmd' (dL -> L l c) = do addError l $ vcat [ text "Arrow command found where an expression was expected:", nest 2 (ppr c) ] return (cL l hsHoleExpr) - ecFromExp' = return - ecHsLam = HsLam noExt - ecHsLet = HsLet noExt - ecOpApp = OpApp noExt - ecHsCase = HsCase noExt - ecHsApp = HsApp noExt - ecHsIf = mkHsIf - ecHsDo = HsDo noExt DoExpr - ecHsPar = HsPar noExt - checkBlockArguments = checkExpBlockArguments - checkDoAndIfThenElse = checkDoAndIfThenElse' + ecpFromExp' = return + mkHsLamPV l mg = return $ cL l (HsLam noExt mg) + mkHsLetPV l bs c = return $ cL l (HsLet noExt bs c) + type InfixOp (HsExpr p) = HsExpr p + superInfixOp m = m + mkHsOpAppPV l e1 op e2 = do + return $ cL l $ OpApp noExt e1 op e2 + mkHsCasePV l e mg = return $ cL l (HsCase noExt e mg) + type FunArg (HsExpr p) = HsExpr p + superFunArg m = m + mkHsAppPV l e1 e2 = do + checkExpBlockArguments e1 + checkExpBlockArguments e2 + return $ cL l (HsApp noExt e1 e2) + mkHsIfPV l c semi1 a semi2 b = do + checkDoAndIfThenElse c semi1 a semi2 b + return $ cL l (mkHsIf c a b) + mkHsDoPV l stmts = return $ cL l (HsDo noExt DoExpr stmts) + mkHsParPV l e = return $ cL l (HsPar noExt e) + mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExt v) + mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExt a) + mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExt a) + mkHsWildCardPV l = return $ cL l hsHoleExpr + mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExt a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExt Nothing xs) + mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExt) sp + mkHsRecordPV l lrec a (fbinds, ddLoc) = do + r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) + checkRecordSyntax (cL l r) + mkHsNegAppPV l a = return $ cL l (NegApp noExt a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ cL l (SectionR noExt op e) + mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty + mkHsAsPatPV l v e = do + opt_TypeApplications <- getBit TypeApplicationsBit + let msg | opt_TypeApplications + = "Type application syntax requires a space before '@'" + | otherwise + = "Did you mean to enable TypeApplications?" + patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) + mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty + mkSumOrTuplePV = mkSumOrTupleExpr + +patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) +patSynErr l e explanation = + do { addError l $ + sep [text "Pattern syntax in expression context:", + nest 4 (ppr e)] $$ + explanation + ; return (cL l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) +-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] +data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderBang SrcSpan (Located (PatBuilder p)) + | PatBuilderPar (Located (PatBuilder p)) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + | PatBuilderVar (Located RdrName) + | PatBuilderOverLit (HsOverLit GhcPs) + +patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) +patBuilderBang bang p = + cL (bang `combineSrcSpans` getLoc p) $ + PatBuilderBang bang p + +instance p ~ GhcPs => Outputable (PatBuilder p) where + ppr (PatBuilderPat p) = ppr p + ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p + ppr (PatBuilderPar (L _ p)) = parens (ppr p) + ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 + ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 + ppr (PatBuilderVar v) = ppr v + ppr (PatBuilderOverLit l) = ppr l + +instance p ~ GhcPs => DisambECP (PatBuilder p) where + type Body (PatBuilder p) = PatBuilder + ecpFromCmd' (dL-> L l c) = + addFatalError l $ + text "Command syntax in pattern:" <+> ppr c + ecpFromExp' (dL-> L l e) = + addFatalError l $ + text "Expression syntax in pattern:" <+> ppr e + mkHsLamPV l _ = addFatalError l $ + text "Lambda-syntax in pattern." $$ + text "Pattern matching on functions is not possible." + mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" + type InfixOp (PatBuilder p) = RdrName + superInfixOp m = m + mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2 + mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" + type FunArg (PatBuilder p) = PatBuilder p + superFunArg m = m + mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) + mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" + mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" + mkHsParPV l p = return $ cL l (PatBuilderPar p) + mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) + mkHsLitPV lit@(dL->L l a) = do + checkUnboxedStringLitPat lit + return $ cL l (PatBuilderPat (LitPat noExt a)) + mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExt)) + mkHsTySigPV l b sig = do + p <- checkLPat b + return $ cL l (PatBuilderPat (SigPat noExt p (mkLHsSigWcType sig))) + mkHsExplicitListPV l xs = do + ps <- traverse checkLPat xs + return (cL l (PatBuilderPat (ListPat noExt ps))) + mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExt sp)) + mkHsRecordPV l _ a (fbinds, ddLoc) = do + r <- mkPatRec a (mk_rec_fields fbinds ddLoc) + checkRecordSyntax (cL l r) + mkHsNegAppPV l (dL->L lp p) = do + lit <- case p of + PatBuilderOverLit pos_lit -> return (cL lp pos_lit) + _ -> patFail l (text "-" <> ppr p) + return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + mkHsSectionR_PV l op p + | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p + | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) + mkHsViewPatPV l a b = do + p <- checkLPat b + return $ cL l (PatBuilderPat (ViewPat noExt a p)) + mkHsAsPatPV l v e = do + p <- checkLPat e + return $ cL l (PatBuilderPat (AsPat noExt v p)) + mkHsLazyPatPV l e = do + p <- checkLPat e + return $ cL l (PatBuilderPat (LazyPat noExt p)) + mkSumOrTuplePV = mkSumOrTuplePat + +checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () +checkUnboxedStringLitPat (dL->L loc lit) = + case lit of + HsStringPrim _ _ -- Trac #13260 + -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) + _ -> return () + +mkPatRec :: + Located (PatBuilder GhcPs) -> + HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> + PV (PatBuilder GhcPs) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) + | isRdrDataCon (unLoc c) + = do fs <- mapM checkPatField fs + return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd)))) +mkPatRec p _ = + addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p + {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2008,9 +2247,19 @@ concerns local to the parser, and does not require duplication of hsSyn types, or an extra pass over the entire AST, is to parse into an overloaded parser-validator (a so-called tagless final encoding): - class ExpCmdI b where ... - instance ExpCmdI HsCmd where ... - instance ExpCmdI HsExp where ... + class DisambECP b where ... + instance p ~ GhcPs => DisambECP (HsCmd p) where ... + instance p ~ GhcPs => DisambECP (HsExp p) where ... + instance p ~ GhcPs => DisambECP (PatBuilder p) where ... + +The 'DisambECP' class contains functions to build and validate 'b'. For example, +to add parentheses we have: + + mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) + +'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for +expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, +see Note [PatBuilder]). Consider the 'alts' production used to parse case-of alternatives: @@ -2018,9 +2267,9 @@ Consider the 'alts' production used to parse case-of alternatives: : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } -We abstract over LHsExpr, and it becomes: +We abstract over LHsExpr GhcPs, and it becomes: - alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -2028,9 +2277,9 @@ We abstract over LHsExpr, and it becomes: Compared to the initial definition, the added bits are: - forall b. ExpCmdI b => PV ( ... ) -- in the type signature - $1 >>= \ $1 -> return $ -- in one reduction rule - $2 >>= \ $2 -> return $ -- in another reduction rule + forall b. DisambECP b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule The overhead is constant relative to the size of the rest of the reduction rule, so this approach scales well to large parser productions. @@ -2316,11 +2565,80 @@ thread 'tag' explicitly: | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } -This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to -more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities. +This encoding works well enough, but introduces an extra GADT unlike the +tagless final encoding, and there's no need for this complexity. -} +{- Note [PatBuilder] +~~~~~~~~~~~~~~~~~~~~ +Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, +so we introduce the notion of a PatBuilder. + +Consider a pattern like this: + + Con a b c + +We parse arguments to "Con" one at a time in the fexp aexp parser production, +building the result with mkHsAppPV, so the intermediate forms are: + + 1. Con + 2. Con a + 3. Con a b + 4. Con a b c + +In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like +this (pseudocode): + + 1. "Con" + 2. HsApp "Con" "a" + 3. HsApp (HsApp "Con" "a") "b" + 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" + +Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have +instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for +the intermediate forms. + +Worse yet, some intermediate forms are not valid patterns at all. For example: + + Con !a !b c + +This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then +rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid +patterns, so we cannot represent them as Pat. + +We also need an intermediate representation to postpone disambiguation between +FunBind and PatBind. Consider: + + a `Con` b = ... + a `fun` b = ... + +How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We +learn this by inspecting an intermediate representation in 'isFunLhs' and +seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate +representation capable of representing both a FunBind and a PatBind, so Pat is +insufficient. + +PatBuilder is an extension of Pat that is capable of representing intermediate +parsing results for patterns and function bindings: + + data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) + | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + ... + +It can represent any pattern via 'PatBuilderPat', but it also has a variety of +other constructors which were added by following a simple principle: we never +pattern match on the pattern stored inside 'PatBuilderPat'. + +For example, in 'splitBang' we need to match on space-separated and +bang-separated patterns, so these are represented with dedicated constructors +'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on +variables, so we have a dedicated 'PatBuilderVar' constructor for this despite +the existence of 'VarPat'. +-} + --------------------------------------------------------------------------- -- Miscellaneous utilities @@ -2342,7 +2660,7 @@ mkRecConstrOrUpdate :: LHsExpr GhcPs -> SrcSpan -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) - -> P (HsExpr GhcPs) + -> PV (HsExpr GhcPs) mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c @@ -2680,6 +2998,8 @@ localPV_msg f (PV m) = PV (local f m) instance MonadP PV where addError srcspan msg = PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg) + addWarning option srcspan msg = + PV $ ReaderT $ \_ -> addWarning option srcspan msg addFatalError srcspan msg = PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg) getBit ext = @@ -2762,35 +3082,67 @@ the error messages. -} -- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV () +hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ addFatalError span (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) -data SumOrTuple - = Sum ConTag Arity (LHsExpr GhcPs) - | Tuple [LHsTupArg GhcPs] +data SumOrTuple b + = Sum ConTag Arity (Located b) + | Tuple [Located (Maybe (Located b))] + +pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc +pprSumOrTuple boxity = \case + Sum alt arity e -> + parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> parClose + Tuple xs -> + parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) + <> parClose + where + ppr_bars n = hsep (replicate n (Outputable.char '|')) + (parOpen, parClose) = + case boxity of + Boxed -> (text "(", text ")") + Unboxed -> (text "(#", text "#)") -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) +mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) -- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) +mkSumOrTupleExpr l boxity (Tuple es) = + return $ cL l (ExplicitTuple noExt (map toTupArg es) boxity) + where + toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs + toTupArg = mapLoc (maybe missingTupArg (Present noExt)) -- Sum -mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum noExt alt arity e) -mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = +mkSumOrTupleExpr l Unboxed (Sum alt arity e) = + return $ cL l (ExplicitSum noExt alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 - (ppr_boxed_sum alt arity e)) + (pprSumOrTuple Boxed a)) + +mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) + +-- Tuple +mkSumOrTuplePat l boxity (Tuple ps) = do + ps' <- traverse toTupPat ps + return $ cL l (PatBuilderPat (TuplePat noExt ps' boxity)) where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc - ppr_boxed_sum alt arity e = - text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) - <+> text ")" + toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) + toTupPat (dL -> L l p) = case p of + Nothing -> addFatalError l (text "Tuple section in pattern context") + Just p' -> checkLPat p' - ppr_bars n = hsep (replicate n (Outputable.char '|')) +-- Sum +mkSumOrTuplePat l Unboxed (Sum alt arity p) = do + p' <- checkLPat p + return $ cL l (PatBuilderPat (SumPat noExt p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} = + addFatalError l (hang (text "Boxed sums not supported:") 2 + (pprSumOrTuple Boxed a)) mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index dd38feb367..7b00a62403 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -140,6 +140,9 @@ rnExpr (HsVar _ (L l v)) rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) +rnExpr (HsUnboundVar x v) + = return (HsUnboundVar x v, emptyFVs) + rnExpr (HsOverLabel x _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on @@ -346,24 +349,6 @@ rnExpr (ArithSeq x _ seq) return (ArithSeq x Nothing new_seq, fvs) } {- -These three are pattern syntax appearing in expressions. -Since all the symbols are reservedops we can simply reject them. -We return a (bogus) EWildPat in each case. --} - -rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole -rnExpr e@(EAsPat {}) - = do { opt_TypeApplications <- xoptM LangExt.TypeApplications - ; let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - ; patSynErr e (text msg) - } -rnExpr e@(EViewPat {}) = patSynErr e empty -rnExpr e@(ELazyPat {}) = patSynErr e empty - -{- ************************************************************************ * * Static values @@ -415,9 +400,6 @@ rnExpr (HsProc x pat body) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr (GhcPass id) -hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) - ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -2087,12 +2069,6 @@ sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) -patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", - nest 4 (ppr e)] $$ - explanation) - ; return (EWildPat noExt, emptyFVs) } - badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds = hang (text "Implicit-parameter bindings illegal in" <+> what) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 2a2f05eea5..bc307568f8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3662,10 +3662,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e -exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat" -exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" -exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" -exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" diff --git a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr index 69839e3920..f50166fd41 100644 --- a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr +++ b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr @@ -1,4 +1,4 @@ -InfixAppPatErr.hs:2:3: error: - Parse error in pattern: f $ do a <- return 3 c +InfixAppPatErr.hs:2:7: error: + do-notation in pattern Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/T984.stderr b/testsuite/tests/parser/should_fail/T984.stderr index 4c723a7869..6d25a36e9e 100644 --- a/testsuite/tests/parser/should_fail/T984.stderr +++ b/testsuite/tests/parser/should_fail/T984.stderr @@ -1,4 +1,4 @@ -T984.hs:6:9: - Parse error in pattern: case () of { _ -> result } +T984.hs:6:9: error: + (case ... of ...)-syntax in pattern Possibly caused by a missing 'do'? diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index aa089de3eb..2fc7f3d326 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -143,3 +143,21 @@ test('unpack_inside_type', normal, compile_fail, ['']) test('unpack_before_opr', normal, compile_fail, ['']) test('T16270', normal, compile_fail, ['']) test('T16270h', normal, compile_fail, ['']) +test('cmdFail001', normal, compile_fail, ['']) +test('cmdFail002', normal, compile_fail, ['']) +test('cmdFail003', normal, compile_fail, ['']) +test('cmdFail004', normal, compile_fail, ['']) +test('cmdFail005', normal, compile_fail, ['']) +test('cmdFail006', normal, compile_fail, ['']) +test('cmdFail007', normal, compile_fail, ['']) +test('cmdFail008', normal, compile_fail, ['']) +test('cmdFail009', normal, compile_fail, ['']) +test('patFail001', normal, compile_fail, ['']) +test('patFail002', normal, compile_fail, ['']) +test('patFail003', normal, compile_fail, ['']) +test('patFail004', normal, compile_fail, ['']) +test('patFail005', normal, compile_fail, ['']) +test('patFail006', normal, compile_fail, ['']) +test('patFail007', normal, compile_fail, ['']) +test('patFail008', normal, compile_fail, ['']) +test('patFail009', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_fail/cmdFail001.hs b/testsuite/tests/parser/should_fail/cmdFail001.hs new file mode 100644 index 0000000000..c5a4f2fc89 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail001.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail001 where + +f = proc x -> _ diff --git a/testsuite/tests/parser/should_fail/cmdFail001.stderr b/testsuite/tests/parser/should_fail/cmdFail001.stderr new file mode 100644 index 0000000000..7f8210ab4b --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail001.stderr @@ -0,0 +1,2 @@ + +cmdFail001.hs:4:15: error: Parse error in command: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail002.hs b/testsuite/tests/parser/should_fail/cmdFail002.hs new file mode 100644 index 0000000000..a75a4d249c --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail002.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail002 where + +f = proc x -> (_ -< _) :: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail002.stderr b/testsuite/tests/parser/should_fail/cmdFail002.stderr new file mode 100644 index 0000000000..1e0393346a --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail002.stderr @@ -0,0 +1,2 @@ + +cmdFail002.hs:4:15: error: Parse error in command: (_ -< _) :: _ diff --git a/testsuite/tests/parser/should_fail/cmdFail003.hs b/testsuite/tests/parser/should_fail/cmdFail003.hs new file mode 100644 index 0000000000..03b8b823d3 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail003.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} +module CmdFail003 where + +f = proc x -> [_ -< _, + _ -< _, + _ -< _, + _ -< _, + _ -< _] diff --git a/testsuite/tests/parser/should_fail/cmdFail003.stderr b/testsuite/tests/parser/should_fail/cmdFail003.stderr new file mode 100644 index 0000000000..21f958174d --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail003.stderr @@ -0,0 +1,3 @@ + +cmdFail003.hs:4:15: error: + Parse error in command: [_ -< _, _ -< _, _ -< _, _ -< _, _ -< _] diff --git a/testsuite/tests/parser/should_fail/cmdFail004.hs b/testsuite/tests/parser/should_fail/cmdFail004.hs new file mode 100644 index 0000000000..89898cb983 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail004.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail004 where + +f = proc x -> (_ -> (_ -< _)) diff --git a/testsuite/tests/parser/should_fail/cmdFail004.stderr b/testsuite/tests/parser/should_fail/cmdFail004.stderr new file mode 100644 index 0000000000..ed14937367 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail004.stderr @@ -0,0 +1,2 @@ + +cmdFail004.hs:4:16: error: Parse error in command: _ -> (_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail005.hs b/testsuite/tests/parser/should_fail/cmdFail005.hs new file mode 100644 index 0000000000..a665ddd916 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail005.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail005 where + +f = proc x -> x@(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail005.stderr b/testsuite/tests/parser/should_fail/cmdFail005.stderr new file mode 100644 index 0000000000..9944ff277c --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail005.stderr @@ -0,0 +1,2 @@ + +cmdFail005.hs:4:15: error: Parse error in command: x@(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail006.hs b/testsuite/tests/parser/should_fail/cmdFail006.hs new file mode 100644 index 0000000000..5953d74170 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail006.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail006 where + +f = proc x -> ~(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail006.stderr b/testsuite/tests/parser/should_fail/cmdFail006.stderr new file mode 100644 index 0000000000..ad64e91648 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail006.stderr @@ -0,0 +1,2 @@ + +cmdFail006.hs:4:15: error: Parse error in command: ~(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail007.hs b/testsuite/tests/parser/should_fail/cmdFail007.hs new file mode 100644 index 0000000000..1d3c3adc17 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail007.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Arrows #-} +module CmdFail007 where + +f = proc x -> + (_ -< _) { a = _ -< _, + b = _ -< _, + c = _ -< _ } diff --git a/testsuite/tests/parser/should_fail/cmdFail007.stderr b/testsuite/tests/parser/should_fail/cmdFail007.stderr new file mode 100644 index 0000000000..82dadb6b67 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail007.stderr @@ -0,0 +1,4 @@ + +cmdFail007.hs:5:7: error: + Parse error in command: + (_ -< _) {a = _ -< _, b = _ -< _, c = _ -< _} diff --git a/testsuite/tests/parser/should_fail/cmdFail008.hs b/testsuite/tests/parser/should_fail/cmdFail008.hs new file mode 100644 index 0000000000..76e9864a9d --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail008.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module CmdFail008 where + +f = proc x -> (! (_ -< _)) diff --git a/testsuite/tests/parser/should_fail/cmdFail008.stderr b/testsuite/tests/parser/should_fail/cmdFail008.stderr new file mode 100644 index 0000000000..0f2f0818d7 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail008.stderr @@ -0,0 +1,2 @@ + +cmdFail008.hs:4:16: error: Parse error in command: !(_ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail009.hs b/testsuite/tests/parser/should_fail/cmdFail009.hs new file mode 100644 index 0000000000..e61ba08189 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail009.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} +module CmdFail009 where + +f = proc x -> (_ -< _, + _ -< _, + _ -< _, + _ -< _, + _ -< _) diff --git a/testsuite/tests/parser/should_fail/cmdFail009.stderr b/testsuite/tests/parser/should_fail/cmdFail009.stderr new file mode 100644 index 0000000000..a0c4af5b77 --- /dev/null +++ b/testsuite/tests/parser/should_fail/cmdFail009.stderr @@ -0,0 +1,3 @@ + +cmdFail009.hs:4:15: error: + Parse error in command: (_ -< _,_ -< _,_ -< _,_ -< _,_ -< _) diff --git a/testsuite/tests/parser/should_fail/patFail001.hs b/testsuite/tests/parser/should_fail/patFail001.hs new file mode 100644 index 0000000000..1e41ed25fe --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail001.hs @@ -0,0 +1,3 @@ +module PatFail001 where + +f (\x -> a) = _ diff --git a/testsuite/tests/parser/should_fail/patFail001.stderr b/testsuite/tests/parser/should_fail/patFail001.stderr new file mode 100644 index 0000000000..6dd20d794d --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail001.stderr @@ -0,0 +1,4 @@ + +patFail001.hs:3:4: error: + Lambda-syntax in pattern. + Pattern matching on functions is not possible. diff --git a/testsuite/tests/parser/should_fail/patFail002.hs b/testsuite/tests/parser/should_fail/patFail002.hs new file mode 100644 index 0000000000..b6be3c4482 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail002.hs @@ -0,0 +1,3 @@ +module PatFail002 where + +f (let a = x in a) = _ diff --git a/testsuite/tests/parser/should_fail/patFail002.stderr b/testsuite/tests/parser/should_fail/patFail002.stderr new file mode 100644 index 0000000000..804bfe9f47 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail002.stderr @@ -0,0 +1,2 @@ + +patFail002.hs:3:4: error: (let ... in ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail003.hs b/testsuite/tests/parser/should_fail/patFail003.hs new file mode 100644 index 0000000000..aab9750ee8 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail003.hs @@ -0,0 +1,3 @@ +module PatFail003 where + +f (case x of a -> b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail003.stderr b/testsuite/tests/parser/should_fail/patFail003.stderr new file mode 100644 index 0000000000..dc6e7aaea0 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail003.stderr @@ -0,0 +1,2 @@ + +patFail003.hs:3:4: error: (case ... of ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail004.hs b/testsuite/tests/parser/should_fail/patFail004.hs new file mode 100644 index 0000000000..0bc1ada01e --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail004.hs @@ -0,0 +1,3 @@ +module PatFail004 where + +f (if c then a else b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail004.stderr b/testsuite/tests/parser/should_fail/patFail004.stderr new file mode 100644 index 0000000000..48d289c348 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail004.stderr @@ -0,0 +1,3 @@ + +patFail004.hs:3:4: error: + (if ... then ... else ...)-syntax in pattern diff --git a/testsuite/tests/parser/should_fail/patFail005.hs b/testsuite/tests/parser/should_fail/patFail005.hs new file mode 100644 index 0000000000..b140752fe9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail005.hs @@ -0,0 +1,3 @@ +module PatFail005 where + +f (do a; b; c) = _ diff --git a/testsuite/tests/parser/should_fail/patFail005.stderr b/testsuite/tests/parser/should_fail/patFail005.stderr new file mode 100644 index 0000000000..1302d62e0c --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail005.stderr @@ -0,0 +1,2 @@ + +patFail005.hs:3:4: error: do-notation in pattern diff --git a/testsuite/tests/parser/should_fail/patFail006.hs b/testsuite/tests/parser/should_fail/patFail006.hs new file mode 100644 index 0000000000..ede9ad3a01 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail006.hs @@ -0,0 +1,3 @@ +module PatFail006 where + +f (-(1)) = _ diff --git a/testsuite/tests/parser/should_fail/patFail006.stderr b/testsuite/tests/parser/should_fail/patFail006.stderr new file mode 100644 index 0000000000..270f738163 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail006.stderr @@ -0,0 +1,2 @@ + +patFail006.hs:3:4: error: Parse error in pattern: -(1) diff --git a/testsuite/tests/parser/should_fail/patFail007.hs b/testsuite/tests/parser/should_fail/patFail007.hs new file mode 100644 index 0000000000..fb6a48d4d8 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail007.hs @@ -0,0 +1,3 @@ +module PatFail007 where + +f (+1) = _ diff --git a/testsuite/tests/parser/should_fail/patFail007.stderr b/testsuite/tests/parser/should_fail/patFail007.stderr new file mode 100644 index 0000000000..f07689ba83 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail007.stderr @@ -0,0 +1,2 @@ + +patFail007.hs:3:4: error: Parse error in pattern: +1 diff --git a/testsuite/tests/parser/should_fail/patFail008.hs b/testsuite/tests/parser/should_fail/patFail008.hs new file mode 100644 index 0000000000..a4b5a3b98e --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail008.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Arrows #-} +module PatFail008 where + +f (a -< b) = _ diff --git a/testsuite/tests/parser/should_fail/patFail008.stderr b/testsuite/tests/parser/should_fail/patFail008.stderr new file mode 100644 index 0000000000..d9957d9ca5 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail008.stderr @@ -0,0 +1,2 @@ + +patFail008.hs:4:4: error: Command syntax in pattern: a -< b diff --git a/testsuite/tests/parser/should_fail/patFail009.hs b/testsuite/tests/parser/should_fail/patFail009.hs new file mode 100644 index 0000000000..53e54a7d58 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail009.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} +module PatFail009 where + +f #a = _ diff --git a/testsuite/tests/parser/should_fail/patFail009.stderr b/testsuite/tests/parser/should_fail/patFail009.stderr new file mode 100644 index 0000000000..0c9fb5de15 --- /dev/null +++ b/testsuite/tests/parser/should_fail/patFail009.stderr @@ -0,0 +1,2 @@ + +patFail009.hs:4:3: error: Expression syntax in pattern: #a |