summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2019-03-17 13:47:09 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2019-03-17 14:56:19 +0300
commitfd4009d80533803a4dee959015b96c1626e5ed88 (patch)
treef8261b50be739b9675ef710d890aa58d0ced5a98
parentcb61371e3260e07be724a04b72a935133f66b514 (diff)
downloadhaskell-wip/pat-builder.tar.gz
PatBuilder - WIPwip/pat-builder
Diffstat
-rw-r--r--compiler/deSugar/Check.hs4
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/PmExpr.hs1
-rw-r--r--compiler/hieFile/HieAst.hs12
-rw-r--r--compiler/hsSyn/HsExpr.hs40
-rw-r--r--compiler/hsSyn/HsExtension.hs8
-rw-r--r--compiler/parser/Parser.y315
-rw-r--r--compiler/parser/RdrHsSyn.hs542
-rw-r--r--compiler/rename/RnExpr.hs30
-rw-r--r--compiler/typecheck/TcRnTypes.hs4
-rw-r--r--testsuite/tests/module/mod69.stderr2
-rw-r--r--testsuite/tests/module/mod70.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/InfixAppPatErr.stderr4
-rw-r--r--testsuite/tests/parser/should_fail/T14588.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/T984.stderr4
-rw-r--r--testsuite/tests/rename/should_fail/T12879.stderr2
-rw-r--r--testsuite/tests/rename/should_fail/rnfail016.stderr2
-rw-r--r--testsuite/tests/rename/should_fail/rnfail016a.stderr2
-rw-r--r--testsuite/tests/rename/should_fail/rnfail051.stderr3
-rw-r--r--testsuite/tests/th/T12411.stderr2
-rw-r--r--testsuite/tests/typecheck/should_fail/T15527.stderr2
21 files changed, 607 insertions, 380 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index db3a501fcf..8522cf4e26 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -915,12 +915,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther (EWildPat noExt) }
+ , pm_grd_expr = PmExprFake }
{-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] PmExprFake
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
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/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index bd0e12e850..d4a03b2919 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -63,6 +63,7 @@ data PmExpr = PmExprVar Name
| PmExprLit PmLit
| PmExprEq PmExpr PmExpr -- Syntactic equality
| PmExprOther (HsExpr GhcTc) -- Note [PmExprOther in PmExpr]
+ | PmExprFake
mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
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 bd63150c02..f17b50ac0e 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
@@ -766,10 +740,6 @@ type instance XArrForm (GhcPass _) = NoExt
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
@@ -940,7 +910,6 @@ ppr_expr (OpApp _ e1 op e2)
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
@@ -1062,11 +1031,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
@@ -1201,10 +1165,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 9a017c250f..e3448ba686 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -541,10 +541,6 @@ type family XArrForm 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
@@ -591,10 +587,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/Parser.y b/compiler/parser/Parser.y
index ed326eb730..052c191049 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 {% runExpCmdP $1 >>= \ $1 ->
+ return $ sLL $1 $> $ mkSpliceDecl $1 }
-- Type classes
--
@@ -2394,7 +2395,7 @@ 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)
+ do { let { e = patBuilderBang (getLoc $1) $2
; l = comb2 $1 $> };
(ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
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 empty NoSrcStrict $1 (snd $2) $3;
+ | infixexp_top opt_sig rhs {% runExpCmdP $1 >>= \ $1 ->
+ do { (ann,r) <- checkValDef empty 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
@@ -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 <- runExpCmdP $1
+ ; v <- checkValSigLhs $1
; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
; return (sLL $1 $> $ SigD noExt $
TypeSig noExt [v] (mkLHsSigWcType $3))} }
@@ -2549,10 +2552,10 @@ quasiquote :: { Located (HsSplice GhcPs) }
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))
- [mu AnnDcolon $2] }
+ : infixexp '::' sigtype { ExpCmdP $
+ runExpCmdP $1 >>= \ $1 ->
+ (epTySig $1 (getLoc $2) $3) >>= \r ->
+ ams r [mu AnnDcolon $2] }
| infixexp '-<' exp {% runExpCmdP $1 >>= \ $1 ->
runExpCmdP $3 >>= \ $3 ->
fmap ecFromCmd $
@@ -2588,24 +2591,26 @@ infixexp :: { ExpCmdP }
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
-infixexp_top :: { LHsExpr GhcPs }
- : exp10_top {% runExpCmdP $1 }
+infixexp_top :: { ExpCmdP }
+ : exp10_top { $1 }
| infixexp_top qop exp10_top
- {% runExpCmdP $3 >>= \ $3 ->
+ { ExpCmdP $
+ runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
do { when (srcSpanEnd (getLoc $2)
== srcSpanStart (getLoc $3)
&& checkIfBang $2) $
warnSpaceAfterBang (comb2 $2 $3);
- ams (sLL $1 $> (OpApp noExt $1 $2 $3))
+ ams (sLL $1 $> (ecOpApp $1 $2 $3))
[mj AnnVal $2]
}
}
exp10_top :: { ExpCmdP }
- : '-' fexp {% runExpCmdP $2 >>= \ $2 ->
- fmap ecFromExp $
- ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
- [mj AnnMinus $1] }
+ : '-' fexp { ExpCmdP $
+ runExpCmdP $2 >>= \ $2 ->
+ epNegApp (comb2 $1 $>) $2 >>= \r ->
+ ams r [mj AnnMinus $1] }
| hpc_annot exp {% runExpCmdP $2 >>= \ $2 ->
@@ -2669,12 +2674,7 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
}
fexp :: { ExpCmdP }
- : fexp aexp {% runExpCmdP $2 >>= \ $2 ->
- checkBlockArguments $2 >>= \_ ->
- return $ ExpCmdP $
- runExpCmdP $1 >>= \ $1 ->
- checkBlockArguments $1 >>= \_ ->
- return (sLL $1 $> (ecHsApp $1 $2)) }
+ : fexp aexp { ExpCmdP (mkHsAppPV $1 $2) }
| fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 ->
checkBlockArguments $1 >>= \_ ->
fmap ecFromExp $
@@ -2687,28 +2687,32 @@ fexp :: { ExpCmdP }
| aexp { $1 }
aexp :: { ExpCmdP }
- : qvar '@' aexp {% runExpCmdP $3 >>= \ $3 ->
- fmap ecFromExp $
- ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
+ : qvar '@' aexp {% (checkPattern empty <=< runExpCmdP) $3 >>= \ $3 ->
+ return $ ExpCmdP $
+ epAsPat (comb2 $1 $>) $1 $3 >>= \r ->
+ ams r [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 {% (checkPattern empty <=< runExpCmdP) $2 >>= \ $2 ->
+ return $ ExpCmdP $
+ epLazyPat (comb2 $1 $>) $2 >>= \r ->
+ ams r [mj AnnTilde $1] }
| '\\' apat apats '->' exp
{ ExpCmdP $
runExpCmdP $5 >>= \ $5 ->
- ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource
+ (ecHsLam (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] }
+ , m_grhss = unguardedGRHSs $5 }])) >>= \r ->
+ ams r [mj AnnLam $1, mu AnnRarrow $4] }
| 'let' binds 'in' exp { ExpCmdP $
runExpCmdP $4 >>= \ $4 ->
- ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
+ (ecHsLet (comb2 $1 $>) (snd (unLoc $2)) $4) >>= \r ->
+ ams r
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
@@ -2723,7 +2727,8 @@ aexp :: { ExpCmdP }
runExpCmdP $5 >>= \ $5 ->
runExpCmdP $8 >>= \ $8 ->
checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
- ams (sLL $1 $> $ ecHsIf $2 $5 $8)
+ (ecHsIf (comb2 $1 $>) $2 $5 $8) >>= \r ->
+ ams r
(mj AnnIf $1:mj AnnThen $4
:mj AnnElse $7
:(map (\l -> mj AnnSemi l) (fst $3))
@@ -2736,16 +2741,13 @@ aexp :: { ExpCmdP }
| 'case' exp 'of' altslist {% runExpCmdP $2 >>= \ $2 ->
return $ ExpCmdP $
$4 >>= \ $4 ->
- ams (cL (comb3 $1 $3 $4) $
- ecHsCase $2 (mkMatchGroup
- FromSource (snd $ unLoc $4)))
- (mj AnnCase $1:mj AnnOf $3
- :(fst $ unLoc $4)) }
+ (ecHsCase (comb3 $1 $3 $4) $2 (mkMatchGroup
+ FromSource (snd $ unLoc $4))) >>= \r ->
+ ams r (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) }
| 'do' stmtlist { ExpCmdP $
$2 >>= \ $2 ->
- ams (cL (comb2 $1 $2)
- (ecHsDo (mapLoc snd $2)))
- (mj AnnDo $1:(fst $ unLoc $2)) }
+ (ecHsDo (comb2 $1 $2) (mapLoc snd $2)) >>= \r ->
+ ams r (mj AnnDo $1:(fst $ unLoc $2)) }
| 'mdo' stmtlist {% $2 >>= \ $2 ->
fmap ecFromExp $
ams (cL (comb2 $1 $2)
@@ -2762,26 +2764,25 @@ aexp :: { ExpCmdP }
| 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 '{' fbinds '}' { ExpCmdP $
+ runExpCmdP $1 >>= \ $1 ->
+ $3 >>= \ $3 ->
+ do { amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3))
+ ; epRecord (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3) }}
| aexp2 { $1 }
aexp2 :: { ExpCmdP }
- : qvar { ecFromExp $ sL1 $1 (HsVar noExt $! $1) }
- | qcon { ecFromExp $ sL1 $1 (HsVar noExt $! $1) }
+ : qvar { ExpCmdP $ epHsVar $1 }
+ | qcon { ExpCmdP $ epHsVar $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) }
+ | literal { ExpCmdP $ epHsLit $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 { ExpCmdP $ epHsOverLit (sL1 $1 $ mkHsIntegral (getINTEGER $1)) }
+ | RATIONAL { ExpCmdP $ epHsOverLit (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
@@ -2790,24 +2791,27 @@ aexp2 :: { ExpCmdP }
| '(' texp ')' { ExpCmdP $
runExpCmdP $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]) } }
+ | '(' tup_exprs ')' { ExpCmdP $
+ $2 >>= \ $2 ->
+ do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
+ ; 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]) } }
+ | '(#' texp '#)' { ExpCmdP $
+ runExpCmdP $2 >>= \ $2 ->
+ do { let sot = Tuple [cL (gl $2) (Just $2)]
+ ; e <- mkSumOrTuple Unboxed (comb2 $1 $3) sot
+ ; ams (sLL $1 $> e) [mo $1,mc $3] } }
+ | '(#' tup_exprs '#)' { ExpCmdP $
+ $2 >>= \ $2 ->
+ do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
+ ; 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 }
+ | '[' list ']' { ExpCmdP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] }
+ | '_' { ExpCmdP $ epWild (getLoc $1) }
-- Template Haskell Extension
- | splice_exp { ecFromExp $1 }
+ | splice_untyped { ExpCmdP $ epSplice $1 }
+ | splice_typed { ecFromExp $ 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] }
@@ -2832,7 +2836,7 @@ aexp2 :: { ExpCmdP }
| '[d|' cvtopbody '|]' {% fmap ecFromExp $
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 { ExpCmdP $ epSplice $1 }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' {% runExpCmdP $2 >>= \ $2 ->
@@ -2902,96 +2906,106 @@ texp :: { ExpCmdP }
-- inside parens.
| infixexp qop {% runExpCmdP $1 >>= \ $1 ->
return $ ecFromExp $
- sLL $1 $> $ SectionL noExt $1 $2 }
- | qopm infixexp {% runExpCmdP $2 >>= \ $2 ->
- return $ ecFromExp $
- sLL $1 $> $ SectionR noExt $1 $2 }
+ sLL $1 $> $ SectionL noExt $1 (mapLoc holeyOpToExpr $2) }
+ | qopm infixexp { ExpCmdP $
+ runExpCmdP $2 >>= \ $2 ->
+ epSectionR (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] }
+ return $ ExpCmdP $
+ (epViewPat $1 (getLoc $2) $3) >>= \r ->
+ ams r [mu AnnRarrow $2] }
-- Always at least one comma or bar.
-tup_exprs :: { ([AddAnn],SumOrTuple) }
+tup_exprs :: { forall b. ExpCmdI b => PV ([AddAnn],SumOrTuple b) }
: texp commas_tup_tail
- {% runExpCmdP $1 >>= \ $1 ->
+ { runExpCmdP $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 { runExpCmdP $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 $
+ { runExpCmdP $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. ExpCmdI b => PV (SrcSpan,[Located (Maybe (Located (b GhcPs)))]) }
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. ExpCmdI b => PV [Located (Maybe (Located (b GhcPs)))] }
+ : texp commas_tup_tail { runExpCmdP $1 >>= \ $1 ->
+ $2 >>= \ $2 ->
+ addAnnotation (gl $1) AnnComma (fst $2) >>
+ return ((cL (gl $1) (Just $1)) : snd $2) }
+ | texp { runExpCmdP $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. ExpCmdI b => SrcSpan -> PV (Located (b GhcPs)) }
+ : texp { \loc ->
+ runExpCmdP $1 >>= \ $1 ->
+ epExplicitList loc [$1] }
+ | lexps { \loc ->
+ $1 >>= \ $1 ->
+ epExplicitList loc (reverse $1) }
+ | texp '..' { \loc -> ecFromExp' $
+ runExpCmdP $1 >>= \ $1 ->
+ ams (cL loc $ ArithSeq noExt Nothing (From $1))
+ [mj AnnDotdot $2] }
+ | texp ',' exp '..' { \loc -> ecFromExp' $
+ runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ ams (cL loc $ ArithSeq noExt Nothing (FromThen $1 $3))
+ [mj AnnComma $2,mj AnnDotdot $4]}
+ | texp '..' exp { \loc -> ecFromExp' $
+ runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ ams (cL loc $ ArithSeq noExt Nothing (FromTo $1 $3))
+ [mj AnnDotdot $2] }
+ | texp ',' exp '..' exp { \loc -> ecFromExp' $
+ runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ runExpCmdP $5 >>= \ $5 ->
+ ams (cL loc $ ArithSeq noExt Nothing (FromThenTo $1 $3 $5))
+ [mj AnnComma $2,mj AnnDotdot $4] }
| texp '|' flattenedpquals
- {% checkMonadComp >>= \ ctxt ->
+ { \loc -> ecFromExp' $
+ checkMonadComp >>= \ ctxt ->
runExpCmdP $1 >>= \ $1 ->
- return ([mj AnnVbar $2],
- mkHsComp ctxt (unLoc $3) $1) }
+ ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) [mj AnnVbar $2] }
-lexps :: { Located [LHsExpr GhcPs] }
- : lexps ',' texp {% runExpCmdP $3 >>= \ $3 ->
- addAnnotation (gl $ head $ unLoc $1)
+lexps :: { forall b. ExpCmdI b => PV [Located (b GhcPs)] }
+ : lexps ',' texp { $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ addAnnotation (gl $ head $ $1)
AnnComma (gl $2) >>
- return (sLL $1 $> (((:) $! $3) $! unLoc $1)) }
- | texp ',' texp {% runExpCmdP $1 >>= \ $1 ->
+ return (((:) $! $3) $! $1) }
+ | texp ',' texp { runExpCmdP $1 >>= \ $1 ->
runExpCmdP $3 >>= \ $3 ->
addAnnotation (gl $1) AnnComma (gl $2) >>
- return (sLL $1 $> [$3,$1]) }
+ return [$3,$1] }
-----------------------------------------------------------------------------
-- List Comprehensions
@@ -3160,8 +3174,7 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
pat :: { LPat GhcPs }
pat : exp {% (checkPattern empty <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty (sLL $1 $> (SectionR noExt
- (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+ amms (checkPattern empty (patBuilderBang (getLoc $1) $2))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
@@ -3171,15 +3184,13 @@ bindpat : exp {% runExpCmdP $1 >>= \ $1 ->
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
amms (checkPattern
(text "Possibly caused by a missing 'do'?")
- (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+ (patBuilderBang (getLoc $1) $2))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
apat : aexp {% (checkPattern empty <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
- amms (checkPattern empty
- (sLL $1 $> (SectionR noExt
- (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+ amms (checkPattern empty (patBuilderBang (getLoc $1) $2))
[mj AnnBang $1] }
apats :: { [LPat GhcPs] }
@@ -3254,26 +3265,32 @@ 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. ExpCmdI b =>
+ PV ([AddAnn],([LHsRecField GhcPs (Located (b GhcPs))], Maybe SrcSpan)) }
: fbinds1 { $1 }
- | {- empty -} { ([],([], Nothing)) }
+ | {- empty -} { return ([],([], Nothing)) }
-fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) }
+fbinds1 :: { forall b. ExpCmdI b =>
+ PV ([AddAnn],([LHsRecField GhcPs (Located (b GhcPs))], 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. ExpCmdI b => PV (LHsRecField GhcPs (Located (b GhcPs))) }
+ : qvar '=' texp { runExpCmdP $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 { return $
+ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
@@ -3505,18 +3522,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 :: { Located HoleyOp } -- used in sections
+ : qvarop { sL1 $1 $ HoleyOp $1 }
+ | qconop { sL1 $1 $ HoleyOp $1 }
| hole_op { $1 }
-qopm :: { LHsExpr GhcPs } -- used in sections
- : qvaropm { sL1 $1 $ HsVar noExt $1 }
- | qconop { sL1 $1 $ HsVar noExt $1 }
+qopm :: { Located HoleyOp } -- used in sections
+ : qvaropm { sL1 $1 $ HoleyOp $1 }
+ | qconop { sL1 $1 $ HoleyOp $1 }
| hole_op { $1 }
-hole_op :: { LHsExpr GhcPs } -- used in sections
-hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt)
+hole_op :: { Located HoleyOp } -- used in sections
+hole_op : '`' '_' '`' {% ams (sLL $1 $> InfixHole)
[mj AnnBackquote $1,mj AnnVal $2
,mj AnnBackquote $3] }
@@ -3943,8 +3960,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 :: Located HoleyOp -> Bool
+checkIfBang (dL->L _ (HoleyOp (dL->L _ op))) = op == bang_RDR
checkIfBang _ = False
-- | Warn about missing space after bang
@@ -4037,8 +4054,8 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
-ams :: Located a -> [AddAnn] -> P (Located a)
-ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
+ams :: HasSrcSpan a => a -> [AddAnn] -> P a
+ams a bs = addAnnsAt (getLoc a) bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
amsL sp bs = addAnnsAt sp bs >> return ()
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 2fd47ac9b2..8f3bf33238 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -57,7 +57,6 @@ module RdrHsSyn (
bang_RDR,
isBangRdr,
isTildeRdr,
- checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -93,15 +92,33 @@ module RdrHsSyn (
ExpCmdP(ExpCmdP, runExpCmdP),
ExpCmdI(..),
ecFromExp,
+ ecFromExp',
ecFromCmd,
ecHsLam,
ecHsLet,
ecOpApp,
ecHsCase,
- ecHsApp,
+ mkHsAppPV,
ecHsIf,
ecHsDo,
ecHsPar,
+ patBuilderBang,
+ HoleyOp(..),
+ holeyOpToExpr,
+ epFromPat,
+ epHsVar,
+ epHsLit,
+ epHsOverLit,
+ epWild,
+ epViewPat,
+ epTySig,
+ epExplicitList,
+ epSplice,
+ epRecord,
+ epNegApp,
+ epSectionR,
+ epLazyPat,
+ epAsPat,
) where
@@ -1005,7 +1022,11 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
-checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
+checkBlockArguments =
+ case expCmdG @b of
+ ExpG -> checkExpr
+ CmdG -> checkCmd
+ PatG -> \_ -> return ()
where
checkExpr :: LHsExpr GhcPs -> P ()
checkExpr expr = case unLoc expr of
@@ -1085,112 +1106,87 @@ 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 :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
-checkPattern msg e = checkLPat msg e
+checkPattern :: SDoc -> Located (PatBuilder GhcPs) -> P (LPat GhcPs)
+checkPattern msg (dL -> L l pb) = checkLPat msg (cL l pb)
-checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
-checkPatterns msg es = mapM (checkPattern msg) es
+checkPatterns :: SDoc -> [Located (PatBuilder GhcPs)] -> P [LPat GhcPs]
+checkPatterns msg es = mapM (checkLPat msg) es
-checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
+checkLPat :: SDoc -> Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkLPat msg e@(dL->L l _) = checkPat msg l e []
-checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
+checkPat :: SDoc -> SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> P (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 =
- patFail (text "Perhaps you intended to use RecursiveDo") l e
+ patFail (text "Perhaps you intended to use RecursiveDo") l (ppr e)
checkPat msg 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'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (dL->L _ (HsApp _ f e)) args
+checkPat msg loc (dL->L _ (PatBuilderApp f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
checkPat msg loc (dL->L _ e) []
= do p <- checkAPat msg loc e
return (cL loc p)
checkPat msg loc e _
- = patFail msg loc (unLoc e)
+ = patFail msg loc (ppr (unLoc e))
-checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
+checkAPat :: SDoc -> SrcSpan -> PatBuilder GhcPs -> P (Pat GhcPs)
checkAPat msg 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)) _
+ PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
+ PatBuilderNegApp (dL->L l (PatBuilderOverLit pos_lit))
-> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr))
- SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
- | bang == bang_RDR
+ PatBuilderBang lb p -- (! x)
-> do { hintBangPat loc e0
- ; e' <- checkLPat msg e
+ ; p' <- checkLPat msg p
; addAnnotation loc AnnBang lb
- ; return (BangPat noExt e') }
+ ; return (BangPat noExt p') }
- ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
- EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
- -- view pattern is well-formed if the pattern is
- EViewPat _ expr patE -> checkLPat msg patE >>=
- (return . (\p -> ViewPat noExt expr p))
- ExprWithTySig _ e t -> do e <- checkLPat msg e
- return (SigPat noExt e t)
+ PatBuilderWithTySig e t -> do
+ e <- checkLPat msg 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 _ (HoleyOp (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
+ PatBuilderOpApp l (dL->L cl (HoleyOp (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
l <- checkLPat msg l
r <- checkLPat msg r
return (ConPatIn (cL cl c) (InfixCon l r))
- OpApp {} -> patFail msg loc e0
-
- ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
- return (ListPat noExt ps)
-
- HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
+ PatBuilderOpApp {} -> patFail msg loc (ppr e0)
- ExplicitTuple _ es b
- | all tupArgPresent es -> do ps <- mapM (checkLPat msg)
- [e | (dL->L _ (Present _ e)) <- es]
- return (TuplePat noExt ps b)
- | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
- $$ ppr e0)
+ PatBuilderPar e -> checkLPat msg e >>= (return . (ParPat noExt))
- ExplicitSum _ alt arity expr -> do
- p <- checkLPat msg expr
- return (SumPat noExt p alt arity)
+ _ -> patFail msg loc (ppr e0)
- RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
- -> do fs <- mapM (checkPatField msg) fs
- return (ConPatIn c (RecCon (HsRecFields fs dd)))
- HsSpliceE _ s | not (isTypedSplice s)
- -> return (SplicePat noExt s)
- _ -> patFail msg loc e0
-
-placeHolderPunRhs :: LHsExpr GhcPs
+placeHolderPunRhs :: forall b. ExpCmdI b => Located (b GhcPs)
-- 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 =
+ case expCmdG @b of
+ ExpG -> noLoc (HsVar noExt (noLoc pun_RDR))
+ CmdG -> panic "placeHolderPunRhs in command context"
+ PatG -> noLoc (PatBuilderVar (noLoc pun_RDR))
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -1202,14 +1198,14 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR)
-checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
+checkPatField :: SDoc -> LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
return (cL l (fld { hsRecFieldArg = p }))
-patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
+patFail :: SDoc -> SrcSpan -> SDoc -> P a
patFail msg loc e = addFatalError loc err
- where err = text "Parse error in pattern:" <+> ppr e
+ where err = text "Parse error in pattern:" <+> e
$$ msg
patIsRec :: RdrName -> Bool
@@ -1221,7 +1217,7 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
checkValDef :: SDoc
-> SrcStrictness
- -> LHsExpr GhcPs
+ -> Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
@@ -1229,7 +1225,7 @@ checkValDef :: SDoc
checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (cL (combineLocs lhs sig)
- (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
+ (PatBuilderWithTySig lhs (mkLHsSigWcType sig))) grhss
checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
@@ -1245,7 +1241,7 @@ checkFunBind :: SDoc
-> SrcSpan
-> Located RdrName
-> LexicalFixity
- -> [LHsExpr GhcPs]
+ -> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
@@ -1275,11 +1271,11 @@ makeFunBind fn ms
fun_tick = [] }
checkPatBind :: SDoc
- -> LHsExpr GhcPs
+ -> Located (PatBuilder GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind msg lhs (dL->L _ (_,grhss))
- = do { lhs <- checkPattern msg lhs
+ = do { lhs <- checkLPat msg lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
@@ -1327,6 +1323,7 @@ checkDoAndIfThenElse =
case expCmdG @b of
ExpG -> checkDoAndIfThenElse'
CmdG -> checkDoAndIfThenElse'
+ PatG -> \_ _ _ _ _ -> return ()
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
@@ -1349,20 +1346,20 @@ 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 (dL->L bang (HoleyOp (dL->L _ op))) r_arg))
+ | op == bang_RDR = Just (l_arg, cL l' (PatBuilderBang bang arg1) : argns)
where
- l' = combineLocs bang arg1
+ l' = combineSrcSpans bang (getLoc 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
--
@@ -1377,17 +1374,15 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] []
where
- go (dL->L loc (HsVar _ (dL->L _ f))) es ann
+ go (dL->L loc (PatBuilderVar (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
@@ -1402,7 +1397,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' (HoleyOp (L _ op))) r)) es ann
| Just (e',es') <- splitBang e
= do { bang_on <- getBit BangPatBit
; if bang_on then go e' (es' ++ es) ann
@@ -1416,8 +1411,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' (HoleyOp (cL loc' op))) r)
_ -> return Nothing }
go _ _ _ = return Nothing
@@ -1914,6 +1909,44 @@ checkMonadComp = do
-- See Note [Ambiguous syntactic categories]
--
+data HoleyOp = HoleyOp (Located RdrName) | InfixHole
+
+instance Outputable HoleyOp where
+ ppr (HoleyOp v) = ppr v
+ ppr InfixHole = text "`_`"
+
+holeyOpToExpr :: HoleyOp -> HsExpr GhcPs
+holeyOpToExpr = \case
+ InfixHole -> hsHoleExpr
+ HoleyOp op -> HsVar noExt op
+
+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 HoleyOp) (Located (PatBuilder p))
+ | PatBuilderVar (Located RdrName)
+ | PatBuilderWithTySig (Located (PatBuilder p)) (LHsSigWcType (NoGhcTc p))
+ | PatBuilderOverLit (HsOverLit p)
+ | PatBuilderNegApp (Located (PatBuilder p))
+
+patBuilderBang :: SrcSpan -> Located (PatBuilder GhcPs) -> Located (PatBuilder GhcPs)
+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 (PatBuilderWithTySig (L _ p) t) = ppr p <+> text "::" <+> ppr t
+ ppr (PatBuilderOverLit l) = ppr l
+ ppr (PatBuilderNegApp p) = text "-" <> ppr p
+
-- ExpCmdP as defined is isomorphic to a pair of parsers:
--
-- data ExpCmdP = ExpCmdP { expP :: PV (LHsExpr GhcPs)
@@ -1928,69 +1961,312 @@ newtype ExpCmdP =
data ExpCmdG b where
ExpG :: ExpCmdG HsExpr
CmdG :: ExpCmdG HsCmd
+ PatG :: ExpCmdG PatBuilder
-- See Note [Ambiguous syntactic categories]
class ExpCmdI b where expCmdG :: ExpCmdG b
instance ExpCmdI HsExpr where expCmdG = ExpG
instance ExpCmdI HsCmd where expCmdG = CmdG
+instance ExpCmdI PatBuilder where expCmdG = PatG
ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
ecFromCmd c@(getLoc -> l) = ExpCmdP onB
where
onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }
+ onB = case expCmdG @b of
+ CmdG -> return c
+ ExpG -> onExp
+ PatG -> onPat
onExp :: P (LHsExpr GhcPs)
onExp = do
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
return (cL l hsHoleExpr)
+ onPat :: P (Located (PatBuilder GhcPs))
+ onPat = do
+ addFatalError l $ vcat
+ [ text "Arrow command found where a pattern was expected:",
+ nest 2 (ppr c) ]
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp e@(getLoc -> l) = ExpCmdP onB
where
onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }
+ onB = case expCmdG @b of
+ ExpG -> return e
+ PatG -> onPat
+ CmdG -> onCmd
onCmd :: P (LHsCmd GhcPs)
onCmd =
addFatalError l $
text "Parse error in command:" <+> ppr e
+ onPat :: P (Located (PatBuilder GhcPs))
+ onPat =
+ addFatalError l $
+ text "Parse error in pattern:" <+> ppr e
+
+ecFromExp' :: ExpCmdI b => PV (LHsExpr GhcPs) -> PV (Located (b GhcPs))
+ecFromExp' ePV = ePV >>= \e -> runExpCmdP (ecFromExp e)
+
+epFromPat :: LPat GhcPs -> ExpCmdP
+epFromPat p@(getLoc -> l) = ExpCmdP onB
+ where
+ onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
+ onB = case expCmdG @b of
+ PatG -> return (cL l (PatBuilderPat (unLoc p)))
+ ExpG -> onExp
+ CmdG -> onCmd
+ onCmd :: P (LHsCmd GhcPs)
+ onCmd =
+ addFatalError l $
+ text "Parse error in command:" <+> ppr p
+ onExp :: P (LHsExpr GhcPs)
+ onExp =
+ addFatalError l $
+ text "Parse error in expression:" <+> ppr p
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
-ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }
+ecHsLam :: forall b. ExpCmdI b =>
+ SrcSpan -> MatchGroup GhcPs (Located (b GhcPs)) -> PV (Located (b GhcPs))
+ecHsLam rLoc =
+ case expCmdG @b of
+ ExpG -> \mg -> return (cL rLoc $ HsLam noExt mg)
+ CmdG -> \mg -> return (cL rLoc $ HsCmdLam noExt mg)
+ PatG -> \_ -> addFatalError rLoc (text "Parse error in pattern: lambda expression")
-ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
-ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
+ecHsLet :: forall b. ExpCmdI b =>
+ SrcSpan -> LHsLocalBinds GhcPs -> Located (b GhcPs) -> PV (Located (b GhcPs))
+ecHsLet rLoc =
+ case expCmdG @b of
+ ExpG -> \lb b -> return (cL rLoc $ HsLet noExt lb b)
+ CmdG -> \lb b -> return (cL rLoc $ HsCmdLet noExt lb b)
+ PatG -> \_ _ -> addFatalError rLoc (text "Parse error in pattern: let expression")
-ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
+ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> Located (HoleyOp)
-> Located (b GhcPs) -> b GhcPs
-ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
+ecOpApp =
+ case expCmdG @b of
+ ExpG -> expOpApp
+ CmdG -> cmdOpApp
+ PatG -> PatBuilderOpApp
where
+ expOpApp e1 op e2 = OpApp noExt e1 (mapLoc holeyOpToExpr op) e2
cmdOpApp c1 op c2 =
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
- HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
+ HsCmdArrForm noExt (mapLoc holeyOpToExpr op) Infix Nothing [cmdArg c1, cmdArg c2]
ecHsCase :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }
+ SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) ->
+ PV (Located (b GhcPs))
+ecHsCase rLoc =
+ case expCmdG @b of
+ ExpG -> \s mg -> return (cL rLoc $ HsCase noExt s mg)
+ CmdG -> \s mg -> return (cL rLoc $ HsCmdCase noExt s mg)
+ PatG -> \_ _ -> addFatalError rLoc (text "Parse error in pattern: case expression")
-ecHsApp :: forall b. ExpCmdI b =>
- Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
-ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
+mkHsAppPV :: forall b. ExpCmdI b => ExpCmdP -> ExpCmdP -> PV (Located (b GhcPs))
+mkHsAppPV a b =
+ case expCmdG @b of
+ ExpG -> do
+ a' <- runExpCmdP a; checkBlockArguments a'
+ b' <- runExpCmdP b; checkBlockArguments b'
+ return (cL (combineSrcSpans (getLoc a') (getLoc b')) $ HsApp noExt a' b')
+ CmdG -> do
+ a' <- runExpCmdP a; checkBlockArguments a'
+ b' <- runExpCmdP b; checkBlockArguments b'
+ return (cL (combineSrcSpans (getLoc a') (getLoc b')) $ HsCmdApp noExt a' b')
+ PatG -> do
+ a' <- runExpCmdP a
+ b' <- runExpCmdP b
+ return (cL (combineSrcSpans (getLoc a') (getLoc b')) $ PatBuilderApp a' b')
ecHsIf :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
-ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
+ SrcSpan -> LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) ->
+ PV (Located (b GhcPs))
+ecHsIf rLoc =
+ case expCmdG @b of
+ ExpG -> \c a b -> return (cL rLoc $ mkHsIf c a b)
+ CmdG -> \c a b -> return (cL rLoc $ mkHsCmdIf c a b)
+ PatG -> \_ _ _ -> addFatalError rLoc (text "Parse error in pattern: if expression")
ecHsDo :: forall b. ExpCmdI b =>
- Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
-ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }
+ SrcSpan -> Located [LStmt GhcPs (Located (b GhcPs))] ->
+ PV (Located (b GhcPs))
+ecHsDo rLoc =
+ case expCmdG @b of
+ ExpG -> \stmts -> return (cL rLoc $ HsDo noExt DoExpr stmts)
+ CmdG -> \stmts -> return (cL rLoc $ HsCmdDo noExt stmts)
+ PatG -> \_ -> addFatalError rLoc (text "Parse error in pattern: do block")
ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
-ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
+ecHsPar =
+ case expCmdG @b of
+ ExpG -> HsPar noExt
+ CmdG -> HsCmdPar noExt
+ PatG -> PatBuilderPar
+
+epHsVar :: forall b. ExpCmdI b => Located RdrName -> PV (Located (b GhcPs))
+epHsVar v =
+ case expCmdG @b of
+ ExpG -> return $ cL (getLoc v) (HsVar noExt v)
+ PatG -> return $ cL (getLoc v) (PatBuilderVar v)
+ CmdG -> addFatalError (getLoc v) $ text "Parse error in command:" <+> ppr v
+
+epHsLit :: forall b. ExpCmdI b => Located (HsLit GhcPs) -> PV (Located (b GhcPs))
+epHsLit l =
+ case expCmdG @b of
+ ExpG -> return $ cL (getLoc l) (HsLit noExt (unLoc l))
+ PatG -> do
+ checkUnboxedStringLitPat l
+ return $ cL (getLoc l) (PatBuilderPat (LitPat noExt (unLoc l)))
+ CmdG -> addFatalError (getLoc l) $ text "Parse error in command:" <+> ppr l
+
+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 ()
+
+epHsOverLit :: forall b. ExpCmdI b => Located (HsOverLit GhcPs) -> PV (Located (b GhcPs))
+epHsOverLit l =
+ case expCmdG @b of
+ ExpG -> return $ cL (getLoc l) (HsOverLit noExt (unLoc l))
+ PatG -> return $ cL (getLoc l) (PatBuilderOverLit (unLoc l))
+ CmdG -> addFatalError (getLoc l) $ text "Parse error in command:" <+> ppr l
+
+epWild :: forall b. ExpCmdI b => SrcSpan -> PV (Located (b GhcPs))
+epWild wspan =
+ case expCmdG @b of
+ ExpG -> return $ cL wspan hsHoleExpr
+ PatG -> return $ cL wspan (PatBuilderPat (WildPat noExt))
+ CmdG -> addFatalError wspan $ text "Parse error in command"
+
+epViewPat :: forall b. ExpCmdI b =>
+ LHsExpr GhcPs -> SrcSpan -> Located (PatBuilder GhcPs) -> PV (Located (b GhcPs))
+epViewPat e arrspan pb =
+ case expCmdG @b of
+ ExpG -> addFatalError arrspan $ text "Parse error in expression"
+ CmdG -> addFatalError arrspan $ text "Parse error in command"
+ PatG -> do
+ p <- checkLPat empty pb
+ let loc = combineSrcSpans (getLoc e) (getLoc p)
+ return $ cL loc $ PatBuilderPat (ViewPat noExt e p)
+
+epTySig :: forall b. ExpCmdI b =>
+ Located (b GhcPs) -> SrcSpan -> LHsType GhcPs -> PV (Located (b GhcPs))
+epTySig a colonspan sig =
+ case expCmdG @b of
+ ExpG -> return $ cL loc $ ExprWithTySig noExt a (mkLHsSigWcType sig)
+ PatG -> return $ cL loc $ PatBuilderWithTySig a (mkLHsSigWcType sig)
+ CmdG -> addFatalError colonspan $ text "Parse error in command"
+ where
+ loc = combineSrcSpans (getLoc a) (getLoc sig)
+
+epExplicitList :: forall b. ExpCmdI b =>
+ SrcSpan -> [Located (b GhcPs)] -> PV (Located (b GhcPs))
+epExplicitList l xs =
+ case expCmdG @b of
+ ExpG -> return (cL l (ExplicitList noExt Nothing xs))
+ PatG -> do
+ ps <- traverse (checkLPat empty) xs
+ return (cL l (PatBuilderPat (ListPat noExt ps)))
+ CmdG -> addFatalError l $ text "Parse error in command"
+
+epSplice :: forall b. ExpCmdI b => Located (HsSplice GhcPs) -> PV (Located (b GhcPs))
+epSplice sp =
+ case expCmdG @b of
+ ExpG -> return (mapLoc (HsSpliceE noExt) sp)
+ PatG -> return (mapLoc (PatBuilderPat . SplicePat noExt) sp)
+ CmdG -> addFatalError (getLoc sp) $ text "Parse error in command"
+
+epRecord :: forall b. ExpCmdI b =>
+ SrcSpan ->
+ SrcSpan ->
+ Located (b GhcPs) ->
+ ([LHsRecField GhcPs (Located (b GhcPs))], Maybe SrcSpan) ->
+ PV (Located (b GhcPs))
+epRecord l lrec a (fbinds, ddLoc) =
+ case expCmdG @b of
+ ExpG -> do
+ r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)
+ checkRecordSyntax (cL l r)
+ PatG -> do
+ r <- mkPatRec a (mk_rec_fields fbinds ddLoc)
+ checkRecordSyntax (cL l r)
+ CmdG -> addFatalError l $ text "Record syntax in command context"
+
+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 empty) fs
+ return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd))))
+mkPatRec p _ =
+ addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
+
+epNegApp :: forall b. ExpCmdI b =>
+ SrcSpan ->
+ Located (b GhcPs) ->
+ PV (Located (b GhcPs))
+epNegApp l a =
+ case expCmdG @b of
+ ExpG -> return $ cL l $ NegApp noExt a noSyntaxExpr
+ PatG -> return $ cL l $ PatBuilderNegApp a
+ CmdG -> addFatalError l $ text "Unary minus in command context"
+
+epSectionR :: forall b. ExpCmdI b =>
+ SrcSpan ->
+ Located HoleyOp ->
+ Located (b GhcPs) ->
+ PV (Located (b GhcPs))
+epSectionR l op a =
+ case expCmdG @b of
+ ExpG -> return $ cL l $ SectionR noExt (mapLoc holeyOpToExpr op) a
+ PatG -> case unLoc op of
+ HoleyOp v | isBangRdr (unLoc v) ->
+ return $ cL l $ PatBuilderBang (getLoc op) a
+ _ -> addFatalError l $ text "Operator section in pattern context"
+ CmdG -> addFatalError l $ text "Prefix bang in command context"
+
+epAsPat :: forall b. ExpCmdI b =>
+ SrcSpan ->
+ Located RdrName ->
+ LPat GhcPs ->
+ PV (Located (b GhcPs))
+epAsPat l v p =
+ case expCmdG @b of
+ PatG -> return $ cL l $ PatBuilderPat (AsPat noExt v p)
+ ExpG ->
+
+ do { opt_TypeApplications <- getBit TypeApplicationsBit
+ ; let msg | opt_TypeApplications
+ = "Type application syntax requires a space before '@'"
+ | otherwise
+ = "Did you mean to enable TypeApplications?"
+ ; addError l $
+ text "@-syntax in expression context" $$
+ text msg
+ ; return (cL l hsHoleExpr)
+ }
+ CmdG -> addFatalError l $ text "@-syntax in command context"
+
+epLazyPat :: forall b. ExpCmdI b =>
+ SrcSpan ->
+ LPat GhcPs ->
+ PV (Located (b GhcPs))
+epLazyPat l a =
+ case expCmdG @b of
+ PatG -> return $ cL l $ PatBuilderPat (LazyPat noExt a)
+ ExpG -> do
+ addError l $ text "Tilde in expression context"
+ return (cL l hsHoleExpr)
+ CmdG -> addFatalError l $ text "Tilde in command context"
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2709,36 +2985,66 @@ not consume any input, but may fail or use other effects. Thus we have:
-}
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
-hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat :: SrcSpan -> PatBuilder GhcPs -> P ()
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 GhcPs))
+ | Tuple [Located (Maybe (Located (b GhcPs)))]
-mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
+mkSumOrTupleExpr :: Boxity -> SrcSpan -> SumOrTuple HsExpr -> PV (HsExpr GhcPs)
-- Tuple
-mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
+mkSumOrTupleExpr boxity _ (Tuple es) = return (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) =
+mkSumOrTupleExpr Unboxed _ (Sum alt arity e) =
return (ExplicitSum noExt alt arity e)
-mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) =
+mkSumOrTupleExpr Boxed l (Sum alt arity (dL->L _ e)) =
addFatalError l (hang (text "Boxed sums not supported:") 2
(ppr_boxed_sum alt arity e))
+
+mkSumOrTuplePat :: Boxity -> SrcSpan -> SumOrTuple PatBuilder -> PV (PatBuilder GhcPs)
+-- Tuple
+mkSumOrTuplePat boxity _ (Tuple ps) = do
+ ps' <- traverse toTupPat ps
+ return (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' -> checkPattern empty p'
+-- Sum
+mkSumOrTuplePat Unboxed _ (Sum alt arity p) = do
+ p' <- checkLPat empty p
+ return (PatBuilderPat (SumPat noExt p' alt arity))
+mkSumOrTuplePat Boxed l (Sum alt arity (dL->L _ p)) =
+ addFatalError l (hang (text "Boxed sums not supported:") 2
+ (ppr_boxed_sum alt arity p))
+
+ppr_boxed_sum :: Outputable a => ConTag -> Arity -> a -> SDoc
+ppr_boxed_sum alt arity e =
+ text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
+ <+> text ")"
+ where
ppr_bars n = hsep (replicate n (Outputable.char '|'))
+mkSumOrTuple :: forall b. ExpCmdI b =>
+ Boxity -> SrcSpan -> SumOrTuple b -> P (b GhcPs)
+mkSumOrTuple boxity loc sot =
+ case expCmdG @b of
+ ExpG -> mkSumOrTupleExpr boxity loc sot
+ PatG -> mkSumOrTuplePat boxity loc sot
+ CmdG -> addFatalError loc (text "Tuple syntax in command context")
+
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index b74b557f49..01989880e2 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 bfedaf2ccc..ea5fcf79c4 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/module/mod69.stderr b/testsuite/tests/module/mod69.stderr
index db7487485e..6963cbe4c1 100644
--- a/testsuite/tests/module/mod69.stderr
+++ b/testsuite/tests/module/mod69.stderr
@@ -1,4 +1,4 @@
mod69.hs:3:7: error:
- Pattern syntax in expression context: x@1
+ @-syntax in expression context
Did you mean to enable TypeApplications?
diff --git a/testsuite/tests/module/mod70.stderr b/testsuite/tests/module/mod70.stderr
index 616ef12376..96f3923df1 100644
--- a/testsuite/tests/module/mod70.stderr
+++ b/testsuite/tests/module/mod70.stderr
@@ -1,2 +1,2 @@
-mod70.hs:3:8: error: Pattern syntax in expression context: ~1
+mod70.hs:3:8: error: Tilde in expression context
diff --git a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr
index 69839e3920..1e67696175 100644
--- a/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr
+++ b/testsuite/tests/parser/should_fail/InfixAppPatErr.stderr
@@ -1,4 +1,2 @@
-InfixAppPatErr.hs:2:3: error:
- Parse error in pattern: f $ do a <- return 3 c
- Possibly caused by a missing 'do'?
+InfixAppPatErr.hs:2:7: error: Parse error in pattern: do block
diff --git a/testsuite/tests/parser/should_fail/T14588.stderr b/testsuite/tests/parser/should_fail/T14588.stderr
index cb64103814..2efd9561e8 100644
--- a/testsuite/tests/parser/should_fail/T14588.stderr
+++ b/testsuite/tests/parser/should_fail/T14588.stderr
@@ -1,4 +1,4 @@
T14588.hs:3:19: error:
Illegal bang-pattern (use BangPatterns):
- ! x
+ !x
diff --git a/testsuite/tests/parser/should_fail/T984.stderr b/testsuite/tests/parser/should_fail/T984.stderr
index 4c723a7869..86cf6150e0 100644
--- a/testsuite/tests/parser/should_fail/T984.stderr
+++ b/testsuite/tests/parser/should_fail/T984.stderr
@@ -1,4 +1,2 @@
-T984.hs:6:9:
- Parse error in pattern: case () of { _ -> result }
- Possibly caused by a missing 'do'?
+T984.hs:6:9: error: Parse error in pattern: case expression
diff --git a/testsuite/tests/rename/should_fail/T12879.stderr b/testsuite/tests/rename/should_fail/T12879.stderr
index 1b3559c255..955c19c3f8 100644
--- a/testsuite/tests/rename/should_fail/T12879.stderr
+++ b/testsuite/tests/rename/should_fail/T12879.stderr
@@ -1,4 +1,4 @@
T12879.hs:4:7: error:
- Pattern syntax in expression context: x@x
+ @-syntax in expression context
Type application syntax requires a space before '@'
diff --git a/testsuite/tests/rename/should_fail/rnfail016.stderr b/testsuite/tests/rename/should_fail/rnfail016.stderr
index 47436132f2..9ef6834307 100644
--- a/testsuite/tests/rename/should_fail/rnfail016.stderr
+++ b/testsuite/tests/rename/should_fail/rnfail016.stderr
@@ -1,4 +1,4 @@
rnfail016.hs:6:7: error:
- Pattern syntax in expression context: x@x
+ @-syntax in expression context
Did you mean to enable TypeApplications?
diff --git a/testsuite/tests/rename/should_fail/rnfail016a.stderr b/testsuite/tests/rename/should_fail/rnfail016a.stderr
index 3a59ee7478..fc622f3800 100644
--- a/testsuite/tests/rename/should_fail/rnfail016a.stderr
+++ b/testsuite/tests/rename/should_fail/rnfail016a.stderr
@@ -1,2 +1,2 @@
-rnfail016a.hs:6:7: error: Pattern syntax in expression context: ~x
+rnfail016a.hs:6:7: error: Tilde in expression context
diff --git a/testsuite/tests/rename/should_fail/rnfail051.stderr b/testsuite/tests/rename/should_fail/rnfail051.stderr
index 9c45a6168b..76763e9a45 100644
--- a/testsuite/tests/rename/should_fail/rnfail051.stderr
+++ b/testsuite/tests/rename/should_fail/rnfail051.stderr
@@ -1,3 +1,2 @@
-rnfail051.hs:7:17: error:
- Pattern syntax in expression context: _ -> putStrLn "_"
+rnfail051.hs:7:19: error: Parse error in expression
diff --git a/testsuite/tests/th/T12411.stderr b/testsuite/tests/th/T12411.stderr
index 1f344323bd..3ea70b4026 100644
--- a/testsuite/tests/th/T12411.stderr
+++ b/testsuite/tests/th/T12411.stderr
@@ -1,4 +1,4 @@
T12411.hs:4:1: error:
- Pattern syntax in expression context: pure@Q
+ @-syntax in expression context
Did you mean to enable TypeApplications?
diff --git a/testsuite/tests/typecheck/should_fail/T15527.stderr b/testsuite/tests/typecheck/should_fail/T15527.stderr
index dd03a0a0ca..fd6c8d77d8 100644
--- a/testsuite/tests/typecheck/should_fail/T15527.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15527.stderr
@@ -1,4 +1,4 @@
T15527.hs:4:6: error:
- Pattern syntax in expression context: (.)@Int
+ @-syntax in expression context
Did you mean to enable TypeApplications?
View Lorry Controller Status