summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2019-02-01 20:03:54 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-02-23 21:37:52 -0500
commite61f6e35e2fffb1e82e9559852481010fe84d8d3 (patch)
tree0846f5666bf0553effbfa72facf3b8557f216492
parent6cce36f83aec33d33545e0ef2135894d22dff5ca (diff)
downloadhaskell-e61f6e35e2fffb1e82e9559852481010fe84d8d3.tar.gz
Expression/command ambiguity resolution
This patch removes 'HsArrApp' and 'HsArrForm' from 'HsExpr' by introducing a new ambiguity resolution system in the parser. Problem: there are places in the grammar where we do not know whether we are parsing an expression or a command: proc x -> do { (stuff) -< x } -- 'stuff' is an expression proc x -> do { (stuff) } -- 'stuff' is a command Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' as an expression or a command. The old solution was to parse as HsExpr always, and rejig later: checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs) This meant polluting 'HsExpr' with command-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 by panicking. We fix this abstraction leak by parsing into an intermediate representation, 'ExpCmd': data ExpCmdG b where ExpG :: ExpCmdG HsExpr CmdG :: ExpCmdG HsCmd type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) checkExp :: ExpCmd -> PV (LHsExpr GhcPs) checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) checkExp f = f ExpG -- interpret as an expression checkCmd f = f CmdG -- interpret as a command 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/command ambiguity. Future work: apply the same principles to the expression/pattern ambiguity.
Diffstat
-rw-r--r--compiler/deSugar/DsExpr.hs2
-rw-r--r--compiler/hieFile/HieAst.hs8
-rw-r--r--compiler/hsSyn/HsExpr.hs50
-rw-r--r--compiler/hsSyn/HsUtils.hs5
-rw-r--r--compiler/parser/Parser.y476
-rw-r--r--compiler/parser/RdrHsSyn.hs628
-rw-r--r--compiler/rename/RnExpr.hs12
-rw-r--r--compiler/typecheck/TcRnTypes.hs2
-rw-r--r--hadrian/src/Settings/Builders/Happy.hs2
-rw-r--r--mk/config.mk.in3
-rw-r--r--testsuite/tests/ghci/scripts/T8959.stderr42
11 files changed, 881 insertions, 349 deletions
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index d9af622b65..c6ba18b1eb 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -752,8 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
-- HsSyn constructs that just shouldn't be here:
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
-ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp"
-ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm"
ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat"
ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat"
ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat"
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index 9ac65ce399..9752403054 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -844,14 +844,6 @@ instance ( a ~ GhcPass p
HsStatic _ expr ->
[ toHie expr
]
- HsArrApp _ a b _ _ ->
- [ toHie a
- , toHie b
- ]
- HsArrForm _ expr _ cmds ->
- [ toHie expr
- , toHie cmds
- ]
HsTick _ _ expr ->
[ toHie expr
]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 01ed872ebd..37d71821c0 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -591,38 +591,6 @@ data HsExpr p
(LHsExpr p) -- Body
---------------------------------------
- -- The following are commands, not expressions proper
- -- They are only used in the parsing stage and are removed
- -- immediately in parser.RdrHsSyn.checkCommand
-
- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',
- -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',
- -- 'ApiAnnotation.AnnRarrowtail'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsArrApp -- Arrow tail, or arrow application (f -< arg)
- (XArrApp p) -- type of the arrow expressions f,
- -- of the form a t t', where arg :: t
- (LHsExpr p) -- arrow expression, f
- (LHsExpr p) -- input expression, arg
- HsArrAppType -- higher-order (-<<) or first-order (-<)
- Bool -- True => right-to-left (f -< arg)
- -- False => left-to-right (arg >- f)
-
- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,
- -- 'ApiAnnotation.AnnCloseB' @'|)'@
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsArrForm -- Command formation, (| e cmd1 .. cmdn |)
- (XArrForm p)
- (LHsExpr p) -- the operator
- -- after type-checking, a type abstraction to be
- -- applied to the type of the local environment tuple
- (Maybe Fixity) -- fixity (filled in by the renamer), for forms that
- -- were converted from OpApp's by the renamer
- [LHsCmdTop p] -- argument commands
-
- ---------------------------------------
-- Haskell program coverage (Hpc) Support
| HsTick
@@ -1144,22 +1112,6 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
ppr exp,
text ")"]
-ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
- = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
- = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
- = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
- = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
-
-ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
- = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
- = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm _ op _ args)
- = hang (text "(|" <+> ppr_lexpr op)
- 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
ppr_expr (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x
@@ -1264,8 +1216,6 @@ hsExprNeedsParens p = go
go (HsTick _ _ (L _ e)) = go e
go (HsBinTick _ _ _ (L _ e)) = go e
go (HsTickPragma _ _ _ _ (L _ e)) = go e
- go (HsArrApp{}) = True
- go (HsArrForm{}) = True
go (RecordCon{}) = False
go (HsRecFld{}) = False
go (XExpr{}) = True
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 7d7ad4411c..16b2cf9dfd 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -28,6 +28,7 @@ module HsUtils(
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
+ mkHsCmdIf,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
@@ -275,6 +276,10 @@ mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-> HsExpr (GhcPass p)
mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
+mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
+ -> HsCmd (GhcPass p)
+mkHsCmdIf c a b = HsCmdIf noExt (Just noSyntaxExpr) c a b
+
mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
mkNPlusKPat id lit
= NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 05bf67498b..63473b4540 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -10,6 +10,10 @@
{
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides the generated Happy parser for Haskell. It exports
-- a number of parsers which may be used in any library that uses the GHC API.
@@ -32,7 +36,7 @@ module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBa
parseType, parseHeader) where
-- base
-import Control.Monad ( unless, liftM, when )
+import Control.Monad ( unless, liftM, when, (<=<) )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
@@ -619,7 +623,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) }
%name parseModule module
%name parseSignature signature
%name parseImport importdecl
-%name parseStatement stmt
+%name parseStatement e_stmt
%name parseDeclaration topdecl
%name parseExpression exp
%name parsePattern pat
@@ -1505,7 +1509,8 @@ decl_cls : at_decl_cls { $1 }
-- A 'default' signature used with the generic-programming extension
| 'default' infixexp '::' sigtypedoc
- {% do { v <- checkValSigLhs $2
+ {% runExpCmdP $2 >>= \ $2 ->
+ do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4)
@@ -1644,7 +1649,9 @@ rules :: { OrdList (LRuleDecl GhcPs) }
rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_foralls infixexp '=' exp
- {%ams (sLL $1 $> $ HsRule { rd_ext = noExt
+ {%runExpCmdP $4 >>= \ $4 ->
+ runExpCmdP $6 >>= \ $6 ->
+ ams (sLL $1 $> $ HsRule { rd_ext = noExt
, rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
@@ -1753,17 +1760,20 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
-----------------------------------------------------------------------------
-- Annotations
annotation :: { LHsDecl GhcPs }
- : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+ : '{-# ANN' name_var aexp '#-}' {% runExpCmdP $3 >>= \ $3 ->
+ ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
(getANN_PRAGs $1)
(ValueAnnProvenance $2) $3))
[mo $1,mc $4] }
- | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+ | '{-# ANN' 'type' tycon aexp '#-}' {% runExpCmdP $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 '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+ | '{-# ANN' 'module' aexp '#-}' {% runExpCmdP $3 >>= \ $3 ->
+ ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
(getANN_PRAGs $1)
ModuleAnnProvenance $3))
[mo $1,mj AnnModule $2,mc $4] }
@@ -2373,7 +2383,8 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
+ | '!' aexp rhs {% runExpCmdP $2 >>= \ $2 ->
+ do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
; l = comb2 $1 $> };
(ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
hintBangPat (comb2 $1 $2) (unLoc e) ;
@@ -2413,7 +2424,8 @@ decl :: { LHsDecl GhcPs }
| splice_exp { sLL $1 $> $ mkSpliceDecl $1 }
rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
- : '=' exp wherebinds { sL (comb3 $1 $2 $3)
+ : '=' exp wherebinds {% runExpCmdP $2 >>= \ $2 -> return $
+ sL (comb3 $1 $2 $3)
((mj AnnEqual $1 : (fst $ unLoc $3))
,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2)
(snd $ unLoc $3)) }
@@ -2426,7 +2438,8 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
| gdrh { sL1 $1 [$1] }
gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
- : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
+ : '|' guardquals '=' exp {% runExpCmdP $4 >>= \ $4 ->
+ ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mj AnnEqual $3] }
sigdecl :: { LHsDecl GhcPs }
@@ -2525,33 +2538,51 @@ quasiquote :: { Located (HsSplice GhcPs) }
; quoterId = mkQual varName (qual, quoter) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
-exp :: { LHsExpr GhcPs }
- : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3))
+exp :: { ExpCmdP }
+ : infixexp '::' sigtype {% runExpCmdP $1 >>= \ $1 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3))
[mu AnnDcolon $2] }
- | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
+ | infixexp '-<' exp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromCmd $
+ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3
HsFirstOrderApp True)
[mu Annlarrowtail $2] }
- | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
+ | infixexp '>-' exp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromCmd $
+ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1
HsFirstOrderApp False)
[mu Annrarrowtail $2] }
- | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
+ | infixexp '-<<' exp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromCmd $
+ ams (sLL $1 $> $ HsCmdArrApp noExt $1 $3
HsHigherOrderApp True)
[mu AnnLarrowtail $2] }
- | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
+ | infixexp '>>-' exp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromCmd $
+ ams (sLL $1 $> $ HsCmdArrApp noExt $3 $1
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
-infixexp :: { LHsExpr GhcPs }
+infixexp :: { ExpCmdP }
: exp10 { $1 }
- | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
+ | infixexp qop exp10 { ExpCmdP $
+ runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ ams (sLL $1 $> (ecOpApp $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
infixexp_top :: { LHsExpr GhcPs }
- : exp10_top { $1 }
+ : exp10_top {% runExpCmdP $1 }
| infixexp_top qop exp10_top
- {% do { when (srcSpanEnd (getLoc $2)
+ {% runExpCmdP $3 >>= \ $3 ->
+ do { when (srcSpanEnd (getLoc $2)
== srcSpanStart (getLoc $3)
&& checkIfBang $2) $
warnSpaceAfterBang (comb2 $2 $3);
@@ -2560,24 +2591,32 @@ infixexp_top :: { LHsExpr GhcPs }
}
}
-exp10_top :: { LHsExpr GhcPs }
- : '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
+exp10_top :: { ExpCmdP }
+ : '-' fexp {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
[mj AnnMinus $1] }
- | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
+ | hpc_annot exp {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ 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 {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+ | '{-# CORE' STRING '#-}' exp {% runExpCmdP $4 >>= \ $4 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
[mo $1,mj AnnVal $2
,mc $3] }
-- hdaume: core annotation
| fexp { $1 }
-exp10 :: { LHsExpr GhcPs }
+exp10 :: { ExpCmdP }
: exp10_top { $1 }
- | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+ | scc_annot exp {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located Token],Bool) }
@@ -2619,128 +2658,176 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
)))
}
-fexp :: { LHsExpr GhcPs }
- : fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >>
- return (sLL $1 $> $ (HsApp noExt $1 $2)) }
- | fexp TYPEAPP atype {% checkBlockArguments $1 >>
+fexp :: { ExpCmdP }
+ : fexp aexp {% runExpCmdP $2 >>= \ $2 ->
+ checkBlockArguments $2 >>= \_ ->
+ return $ ExpCmdP $
+ runExpCmdP $1 >>= \ $1 ->
+ checkBlockArguments $1 >>= \_ ->
+ return (sLL $1 $> (ecHsApp $1 $2)) }
+ | fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 ->
+ checkBlockArguments $1 >>= \_ ->
+ fmap ecFromExp $
ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
- | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2)
+ | 'static' aexp {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ HsStatic noExt $2)
[mj AnnStatic $1] }
| aexp { $1 }
-aexp :: { LHsExpr GhcPs }
- : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
+aexp :: { ExpCmdP }
+ : qvar '@' aexp {% runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
-- If you change the parsing, make sure to understand
-- Note [Lexing type applications] in Lexer.x
- | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] }
+ | '~' aexp {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] }
| '\\' apat apats '->' exp
- {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource
+ { ExpCmdP $
+ runExpCmdP $5 >>= \ $5 ->
+ ams (sLL $1 $> $ ecHsLam (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 {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4)
+ | 'let' binds 'in' exp { ExpCmdP $
+ runExpCmdP $4 >>= \ $4 ->
+ ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
- {% ams (sLL $1 $> $ HsLamCase noExt
+ {% $3 >>= \ $3 ->
+ fmap ecFromExp $
+ 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
- {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
- ams (sLL $1 $> $ mkHsIf $2 $5 $8)
+ {% runExpCmdP $2 >>= \ $2 ->
+ return $ ExpCmdP $
+ runExpCmdP $5 >>= \ $5 ->
+ runExpCmdP $8 >>= \ $8 ->
+ checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
+ ams (sLL $1 $> $ ecHsIf $2 $5 $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) >>
+ | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ ->
+ fmap ecFromExp $
ams (sLL $1 $> $ HsMultiIf noExt
(reverse $ snd $ unLoc $2))
(mj AnnIf $1:(fst $ unLoc $2)) }
- | 'case' exp 'of' altslist {% ams (cL (comb3 $1 $3 $4) $
- HsCase noExt $2 (mkMatchGroup
+ | '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)) }
- | 'do' stmtlist {% ams (cL (comb2 $1 $2)
- (mkHsDo DoExpr (snd $ unLoc $2)))
+ | 'do' stmtlist { ExpCmdP $
+ $2 >>= \ $2 ->
+ ams (cL (comb2 $1 $2)
+ (ecHsDo (mapLoc snd $2)))
(mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% ams (cL (comb2 $1 $2)
+ | 'mdo' stmtlist {% $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (cL (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
- {% checkPattern empty $2 >>= \ p ->
- checkCommand $4 >>= \ cmd ->
+ {% (checkPattern empty <=< runExpCmdP) $2 >>= \ p ->
+ runExpCmdP $4 >>= \ $4@cmd ->
+ fmap ecFromExp $
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 :: { LHsExpr GhcPs }
- : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
+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))
- ; checkRecordSyntax (sLL $1 $> r) }}
+ ; fmap ecFromExp $
+ checkRecordSyntax (sLL $1 $> r) }}
| aexp2 { $1 }
-aexp2 :: { LHsExpr GhcPs }
- : qvar { sL1 $1 (HsVar noExt $! $1) }
- | qcon { sL1 $1 (HsVar noExt $! $1) }
- | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) }
- | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) }
- | literal { sL1 $1 (HsLit noExt $! unLoc $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) }
-- 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 { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) }
- | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) }
+ | INTEGER { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) }
+ | RATIONAL { ecFromExp $ sL (getLoc $1) (HsOverLit noExt $! 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 ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] }
+ | '(' 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)
- ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
+ ; fmap ecFromExp $
+ ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
- | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2)
+ | '(#' 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)
- ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
+ ; fmap ecFromExp $
+ ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
- | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
- | '_' { sL1 $1 $ EWildPat noExt }
+ | '[' list ']' {% fmap ecFromExp $ ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
+ | '_' { ecFromExp $ sL1 $1 $ EWildPat noExt }
-- Template Haskell Extension
- | splice_exp { $1 }
+ | splice_exp { ecFromExp $1 }
- | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
- | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+ | 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] }
| TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
- | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
+ | '[|' exp '|]' {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ 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 '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
+ | '[||' exp '||]' {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
- | '[t|' ktype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
- | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
+ | '[t|' ktype '|]' {% fmap ecFromExp $
+ ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
+ | '[p|' infixexp '|]' {% (checkPattern empty <=< runExpCmdP) $2 >>= \p ->
+ fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
- | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
+ | '[d|' cvtopbody '|]' {% fmap ecFromExp $
+ ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
(mo $1:mu AnnCloseQ $3:fst $2) }
- | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
+ | quasiquote { ecFromExp $ sL1 $1 (HsSpliceE noExt (unLoc $1)) }
-- arrow notation extension
- | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2
+ | '(|' aexp2 cmdargs '|)' {% runExpCmdP $2 >>= \ $2 ->
+ fmap ecFromCmd $
+ ams (sLL $1 $> $ HsCmdArrForm noExt $2 Prefix
Nothing (reverse $3))
[mu AnnOpenB $1,mu AnnCloseB $4] }
@@ -2753,7 +2840,8 @@ splice_untyped :: { Located (HsSplice GhcPs) }
(sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_SPLICE $1)))))
[mj AnnThIdSplice $1] }
- | '$(' exp ')' {% ams (sLL $1 $> $ mkUntypedSplice HasParens $2)
+ | '$(' exp ')' {% runExpCmdP $2 >>= \ $2 ->
+ ams (sLL $1 $> $ mkUntypedSplice HasParens $2)
[mj AnnOpenPE $1,mj AnnCloseP $3] }
splice_typed :: { Located (HsSplice GhcPs) }
@@ -2761,7 +2849,8 @@ splice_typed :: { Located (HsSplice GhcPs) }
(sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
(getTH_ID_TY_SPLICE $1)))))
[mj AnnThIdTySplice $1] }
- | '$$(' exp ')' {% ams (sLL $1 $> $ mkTypedSplice HasParens $2)
+ | '$$(' exp ')' {% runExpCmdP $2 >>= \ $2 ->
+ ams (sLL $1 $> $ mkTypedSplice HasParens $2)
[mj AnnOpenPTE $1,mj AnnCloseP $3] }
cmdargs :: { [LHsCmdTop GhcPs] }
@@ -2769,8 +2858,8 @@ cmdargs :: { [LHsCmdTop GhcPs] }
| {- empty -} { [] }
acmd :: { LHsCmdTop GhcPs }
- : aexp2 {% checkCommand $1 >>= \ cmd ->
- return (sL1 $1 $ HsCmdTop noExt cmd) }
+ : aexp2 {% runExpCmdP $1 >>= \ cmd ->
+ return (sL1 cmd $ HsCmdTop noExt cmd) }
cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
: '{' cvtopdecls0 '}' { ([mj AnnOpenC $1
@@ -2787,7 +2876,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 :: { LHsExpr GhcPs }
+texp :: { ExpCmdP }
: exp { $1 }
-- Note [Parsing sections]
@@ -2801,19 +2890,28 @@ texp :: { LHsExpr GhcPs }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
- | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 }
- | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 }
+ | 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 }
-- View patterns get parenthesized above
- | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
+ | exp '->' texp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ fmap ecFromExp $
+ ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
-- Always at least one comma or bar.
tup_exprs :: { ([AddAnn],SumOrTuple) }
: texp commas_tup_tail
- {% do { addAnnotation (gl $1) AnnComma (fst $2)
+ {% runExpCmdP $1 >>= \ $1 ->
+ do { addAnnotation (gl $1) AnnComma (fst $2)
; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
- | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) }
+ | 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)
@@ -2821,7 +2919,8 @@ tup_exprs :: { ([AddAnn],SumOrTuple) }
([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } }
| bars texp bars0
- { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
+ {% 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]) }
@@ -2833,9 +2932,11 @@ commas_tup_tail : commas tup_tail
-- Always follows a comma
tup_tail :: { [LHsTupArg GhcPs] }
- : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
+ : texp commas_tup_tail {% runExpCmdP $1 >>= \ $1 ->
+ addAnnotation (gl $1) AnnComma (fst $2) >>
return ((cL (gl $1) (Present noExt $1)) : snd $2) }
- | texp { [cL (gl $1) (Present noExt $1)] }
+ | texp {% runExpCmdP $1 >>= \ $1 ->
+ return [cL (gl $1) (Present noExt $1)] }
| {- empty -} { [noLoc missingTupArg] }
-----------------------------------------------------------------------------
@@ -2844,29 +2945,42 @@ tup_tail :: { [LHsTupArg GhcPs] }
-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.
list :: { ([AddAnn],HsExpr GhcPs) }
- : texp { ([],ExplicitList noExt Nothing [$1]) }
+ : texp {% runExpCmdP $1 >>= \ $1 ->
+ return ([],ExplicitList noExt Nothing [$1]) }
| lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) }
- | texp '..' { ([mj AnnDotdot $2],
+ | texp '..' {% runExpCmdP $1 >>= \ $1 ->
+ return ([mj AnnDotdot $2],
ArithSeq noExt Nothing (From $1)) }
- | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4],
+ | texp ',' exp '..' {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ return ([mj AnnComma $2,mj AnnDotdot $4],
ArithSeq noExt Nothing
(FromThen $1 $3)) }
- | texp '..' exp { ([mj AnnDotdot $2],
+ | texp '..' exp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ return ([mj AnnDotdot $2],
ArithSeq noExt Nothing
(FromTo $1 $3)) }
- | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
+ | 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)) }
| texp '|' flattenedpquals
{% checkMonadComp >>= \ ctxt ->
+ runExpCmdP $1 >>= \ $1 ->
return ([mj AnnVbar $2],
mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr GhcPs] }
- : lexps ',' texp {% addAnnotation (gl $ head $ unLoc $1)
+ : lexps ',' texp {% runExpCmdP $3 >>= \ $3 ->
+ addAnnotation (gl $ head $ unLoc $1)
AnnComma (gl $2) >>
return (sLL $1 $> (((:) $! $3) $! unLoc $1)) }
- | texp ',' texp {% addAnnotation (gl $1) AnnComma (gl $2) >>
+ | texp ',' texp {% runExpCmdP $1 >>= \ $1 ->
+ runExpCmdP $3 >>= \ $3 ->
+ addAnnotation (gl $1) AnnComma (gl $2) >>
return (sLL $1 $> [$3,$1]) }
-----------------------------------------------------------------------------
@@ -2898,11 +3012,13 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
amsL (comb2 $1 $>) (fst $ unLoc $3) >>
return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
| squals ',' qual
- {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
+ {% $3 >>= \ $3 ->
+ addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
- | qual { sL1 $1 [$1] }
+ | qual {% $1 >>= \ $1 ->
+ return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
@@ -2913,13 +3029,22 @@ 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 { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }
- | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> (mkTransformByStmt ss $2 $4)) }
+ : 'then' exp {% runExpCmdP $2 >>= \ $2 -> return $
+ sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }
+ | 'then' exp 'by' exp {% runExpCmdP $2 >>= \ $2 ->
+ runExpCmdP $4 >>= \ $4 ->
+ return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],
+ \ss -> (mkTransformByStmt ss $2 $4)) }
| 'then' 'group' 'using' exp
- { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) }
+ {% runExpCmdP $4 >>= \ $4 ->
+ return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3],
+ \ss -> (mkGroupUsingStmt ss $4)) }
| 'then' 'group' 'by' exp 'using' exp
- { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) }
+ {% runExpCmdP $4 >>= \ $4 ->
+ runExpCmdP $6 >>= \ $6 ->
+ return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5],
+ \ss -> (mkGroupByUsingStmt ss $4 $6)) }
-- Note that 'group' is a special_id, which means that you can enable
-- TransformListComp while still using Data.List.group. However, this
@@ -2933,72 +3058,89 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
- : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma
+ : guardquals1 ',' qual {% $3 >>= \ $3 ->
+ addAnnotation (gl $ head $ unLoc $1) AnnComma
(gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
- | qual { sL1 $1 [$1] }
+ | qual {% $1 >>= \ $1 ->
+ return $ sL1 $1 [$1] }
-----------------------------------------------------------------------------
-- Case alternatives
-altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
- : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
+altslist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : '{' alts '}' { $2 >>= \ $2 -> return $
+ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse (snd $ unLoc $2))) }
- | vocurly alts close { cL (getLoc $2) (fst $ unLoc $2
+ | vocurly alts close { $2 >>= \ $2 -> return $
+ cL (getLoc $2) (fst $ unLoc $2
,(reverse (snd $ unLoc $2))) }
- | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) }
- | vocurly close { noLoc ([],[]) }
-
-alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
- : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
- | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2))
+ | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) }
+ | vocurly close { return $ noLoc ([],[]) }
+
+alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : 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 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
- : alts1 ';' alt {% if null (snd $ unLoc $1)
+alts1 :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1 ';' alt { $1 >>= \ $1 ->
+ $3 >>= \ $3 ->
+ if null (snd $ unLoc $1)
then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
,[$3]))
else (ams (head $ snd $ unLoc $1)
(mj AnnSemi $2:(fst $ unLoc $1))
>> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) }
- | alts1 ';' {% if null (snd $ unLoc $1)
+ | alts1 ';' { $1 >>= \ $1 ->
+ if null (snd $ unLoc $1)
then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
,snd $ unLoc $1))
else (ams (head $ snd $ unLoc $1)
(mj AnnSemi $2:(fst $ unLoc $1))
>> return (sLL $1 $> ([],snd $ unLoc $1))) }
- | alt { sL1 $1 ([],[$1]) }
+ | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }
-alt :: { LMatch GhcPs (LHsExpr GhcPs) }
- : pat alt_rhs {%ams (sLL $1 $> (Match { m_ext = noExt
+alt :: { forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs))) }
+ : pat alt_rhs { $2 >>= \ $2 ->
+ ams (sLL $1 $> (Match { m_ext = noExt
, m_ctxt = CaseAlt
, m_pats = [$1]
, m_grhss = snd $ unLoc $2 }))
(fst $ unLoc $2)}
-alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
- : ralt wherebinds { sLL $1 $> (fst $ unLoc $2,
- GRHSs noExt (unLoc $1) (snd $ unLoc $2)) }
+alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (b GhcPs)))) }
+ : ralt wherebinds { $1 >>= \alt ->
+ return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) }
-ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
- : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
- [mu AnnRarrow $1] }
- | gdpats { sL1 $1 (reverse (unLoc $1)) }
+ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
+ : '->' exp { runExpCmdP $2 >>= \ $2 ->
+ ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
+ [mu AnnRarrow $1] }
+ | gdpats { $1 >>= \gdpats ->
+ return $ sL1 gdpats (reverse (unLoc gdpats)) }
-gdpats :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
- : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) }
- | gdpat { sL1 $1 [$1] }
+gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
+ : gdpats gdpat { $1 >>= \gdpats ->
+ $2 >>= \gdpat ->
+ return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }
+ | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }
-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
- : '{' gdpats '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
- | gdpats close { sL1 $1 ([],unLoc $1) }
+ : '{' gdpats '}' {% $2 >>= \ $2 ->
+ return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
+ | gdpats close {% $1 >>= \ $1 ->
+ return $ sL1 $1 ([],unLoc $1) }
-gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) }
+gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
: '|' guardquals '->' exp
- {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
+ { runExpCmdP $4 >>= \ $4 ->
+ ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mu AnnRarrow $3] }
-- 'pat' recognises a pattern, including one with a bang at the top
@@ -3006,22 +3148,26 @@ gdpat :: { LGRHS GhcPs (LHsExpr 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 empty $1 }
- | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt
+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)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
-bindpat : exp {% checkPattern
+bindpat : exp {% runExpCmdP $1 >>= \ $1 ->
+ checkPattern
(text "Possibly caused by a missing 'do'?") $1 }
- | '!' aexp {% amms (checkPattern
+ | '!' 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)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
-apat : aexp {% checkPattern empty $1 }
- | '!' aexp {% amms (checkPattern empty
+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)))
[mj AnnBang $1] }
@@ -3033,10 +3179,12 @@ apats :: { [LPat GhcPs] }
-----------------------------------------------------------------------------
-- Statement sequences
-stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) }
- : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
+stmtlist :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) }
+ : '{' stmts '}' { $2 >>= \ $2 -> return $
+ sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))
,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?
- | vocurly stmts close { cL (gl $2) (fst $ unLoc $2
+ | vocurly stmts close { $2 >>= \ $2 -> return $
+ cL (gl $2) (fst $ unLoc $2
,reverse $ snd $ unLoc $2) }
-- do { ;; s ; s ; ; s ;; }
@@ -3045,40 +3193,52 @@ stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) }
-- So we use BodyStmts throughout, and switch the last one over
-- in ParseUtils.checkDo instead
-stmts :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) }
- : stmts ';' stmt {% if null (snd $ unLoc $1)
+stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))])) }
+ : stmts ';' stmt { $1 >>= \ $1 ->
+ $3 >>= \ $3 ->
+ if null (snd $ unLoc $1)
then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)
,$3 : (snd $ unLoc $1)))
else do
{ ams (head $ snd $ unLoc $1) [mj AnnSemi $2]
; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}
- | stmts ';' {% if null (snd $ unLoc $1)
+ | stmts ';' { $1 >>= \ $1 ->
+ if null (snd $ unLoc $1)
then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1))
else do
{ ams (head $ snd $ unLoc $1)
[mj AnnSemi $2]
- ; return $1 } }
- | stmt { sL1 $1 ([],[$1]) }
- | {- empty -} { noLoc ([],[]) }
+ ; return $1 }
+ }
+ | stmt { $1 >>= \ $1 ->
+ return $ sL1 $1 ([],[$1]) }
+ | {- empty -} { return $ noLoc ([],[]) }
-- For typing stmts at the GHCi prompt, where
-- the input may consist of just comments.
maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
- : stmt { Just $1 }
+ : stmt {% fmap Just $1 }
| {- nothing -} { Nothing }
-stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
+-- For GHC API.
+e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
+ : stmt {% $1 }
+
+stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
: qual { $1 }
- | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))
+ | 'rec' stmtlist { $2 >>= \ $2 ->
+ ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))
(mj AnnRec $1:(fst $ unLoc $2)) }
-qual :: { LStmt GhcPs (LHsExpr GhcPs) }
- : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3)
+qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
+ : bindpat '<-' exp { runExpCmdP $3 >>= \ $3 ->
+ ams (sLL $1 $> $ mkBindStmt $1 $3)
[mu AnnLarrow $2] }
- | exp { sL1 $1 $ mkBodyStmt $1 }
- | 'let' binds {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2))
+ | exp { runExpCmdP $1 >>= \ $1 ->
+ return $ sL1 $1 $ mkBodyStmt $1 }
+ | 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
-----------------------------------------------------------------------------
@@ -3096,7 +3256,8 @@ fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)) }
| '..' { ([mj AnnDotdot $1],([], Just (getLoc $1))) }
fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) }
- : qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
+ : 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 (Trac #6038)
-- and, incidentally, sections. Eg
@@ -3120,7 +3281,8 @@ dbinds :: { Located [LIPBind GhcPs] }
-- | {- empty -} { [] }
dbind :: { LIPBind GhcPs }
-dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3))
+dbind : ipvar '=' exp {% runExpCmdP $3 >>= \ $3 ->
+ ams (sLL $1 $> (IPBind noExt (Left $1) $3))
[mj AnnEqual $2] }
ipvar :: { Located HsIPName }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 12a9c05514..0c3ed74c3b 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -9,6 +9,12 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
module RdrHsSyn (
mkHsOpApp,
@@ -53,7 +59,6 @@ module RdrHsSyn (
isTildeRdr,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkMonadComp, -- P (HsStmtContext RdrName)
- checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
checkDoAndIfThenElse,
@@ -81,7 +86,22 @@ module RdrHsSyn (
warnStarIsType,
failOpFewArgs,
- SumOrTuple (..), mkSumOrTuple
+ SumOrTuple (..), mkSumOrTuple,
+
+ -- Expression/command ambiguity resolution
+ PV,
+ ExpCmdP(ExpCmdP, runExpCmdP),
+ ExpCmdI(..),
+ ecFromExp,
+ ecFromCmd,
+ ecHsLam,
+ ecHsLet,
+ ecOpApp,
+ ecHsCase,
+ ecHsApp,
+ ecHsIf,
+ ecHsDo,
+ ecHsPar,
) where
@@ -984,24 +1004,37 @@ 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 :: LHsExpr GhcPs -> P ()
-checkBlockArguments expr = case unLoc expr of
- HsDo _ DoExpr _ -> check "do block"
- HsDo _ MDoExpr _ -> check "mdo block"
- HsLam {} -> check "lambda expression"
- HsCase {} -> check "case expression"
- HsLamCase {} -> check "lambda-case expression"
- HsLet {} -> check "let expression"
- HsIf {} -> check "if expression"
- HsProc {} -> check "proc expression"
- _ -> return ()
+checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
+checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
where
- check element = do
+ checkExpr :: LHsExpr GhcPs -> P ()
+ checkExpr expr = case unLoc expr of
+ HsDo _ DoExpr _ -> check "do block" expr
+ HsDo _ MDoExpr _ -> check "mdo block" expr
+ HsLam {} -> check "lambda expression" expr
+ HsCase {} -> check "case expression" expr
+ HsLamCase {} -> check "lambda-case expression" expr
+ HsLet {} -> check "let expression" expr
+ HsIf {} -> check "if expression" expr
+ HsProc {} -> check "proc expression" expr
+ _ -> return ()
+
+ checkCmd :: LHsCmd GhcPs -> P ()
+ checkCmd cmd = case unLoc cmd of
+ HsCmdLam {} -> check "lambda command" cmd
+ HsCmdCase {} -> check "case command" cmd
+ HsCmdIf {} -> check "if command" cmd
+ HsCmdLet {} -> check "let command" cmd
+ HsCmdDo {} -> check "do command" cmd
+ _ -> return ()
+
+ check :: (HasSrcSpan a, Outputable a) => String -> a -> P ()
+ check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
- addError (getLoc expr) $
+ addError (getLoc a) $
text "Unexpected " <> text element <> text " in function application:"
- $$ nest 4 (ppr expr)
+ $$ nest 4 (ppr a)
$$ text "You could write it with parentheses"
$$ text "Or perhaps you meant to enable BlockArguments?"
@@ -1282,14 +1315,23 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
-
-checkDoAndIfThenElse :: LHsExpr GhcPs
- -> Bool
- -> LHsExpr GhcPs
- -> Bool
- -> LHsExpr GhcPs
- -> P ()
-checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
+checkDoAndIfThenElse
+ :: forall b. ExpCmdI b =>
+ LHsExpr GhcPs
+ -> Bool
+ -> Located (b GhcPs)
+ -> Bool
+ -> Located (b GhcPs)
+ -> P ()
+checkDoAndIfThenElse =
+ case expCmdG @b of
+ ExpG -> checkDoAndIfThenElse'
+ CmdG -> checkDoAndIfThenElse'
+
+checkDoAndIfThenElse'
+ :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
+ => a -> Bool -> b -> Bool -> c -> P ()
+checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do
@@ -1868,100 +1910,428 @@ checkMonadComp = do
else ListComp
-- -------------------------------------------------------------------------
--- Checking arrow syntax.
+-- Expression/command ambiguity (arrow syntax).
+-- See Note [Ambiguous syntactic categories]
+--
--- We parse arrow syntax as expressions and check for valid syntax below,
--- converting the expression into a pattern at the same time.
+-- 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 { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+
+-- See Note [Ambiguous syntactic categories]
+data ExpCmdG b where
+ ExpG :: ExpCmdG HsExpr
+ CmdG :: ExpCmdG HsCmd
+
+-- See Note [Ambiguous syntactic categories]
+class ExpCmdI b where expCmdG :: ExpCmdG b
+instance ExpCmdI HsExpr where expCmdG = ExpG
+instance ExpCmdI HsCmd where expCmdG = CmdG
+
+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 }
+ 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)
+
+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 }
+ onCmd :: P (LHsCmd GhcPs)
+ onCmd =
+ addFatalError l $
+ text "Parse error in command:" <+> ppr e
+
+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 }
-checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
-checkCommand lc = locMap checkCmd lc
-
-locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
-locMap f (dL->L l a) = f l a >>= (\b -> return $ cL l b)
-
-checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
-checkCmd _ (HsArrApp _ e1 e2 haat b) =
- return $ HsCmdArrApp noExt e1 e2 haat b
-checkCmd _ (HsArrForm _ e mf args) =
- return $ HsCmdArrForm noExt e Prefix mf args
-checkCmd _ (HsApp _ e1 e2) =
- checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
-checkCmd _ (HsLam _ mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
-checkCmd _ (HsPar _ e) =
- checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
-checkCmd _ (HsCase _ e mg) =
- checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
-checkCmd _ (HsIf _ cf ep et ee) = do
- pt <- checkCommand et
- pe <- checkCommand ee
- return $ HsCmdIf noExt cf ep pt pe
-checkCmd _ (HsLet _ lb e) =
- checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
-checkCmd _ (HsDo _ DoExpr (dL->L l stmts)) =
- mapM checkCmdLStmt stmts >>=
- (\ss -> return $ HsCmdDo noExt (cL l ss) )
-
-checkCmd _ (OpApp _ eLeft op eRight) = do
- -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
- c1 <- checkCommand eLeft
- c2 <- checkCommand eRight
- let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1
- arg2 = cL (getLoc c2) $ HsCmdTop noExt c2
- return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
-
-checkCmd l e = cmdFail l e
-
-checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
-checkCmdLStmt = locMap checkCmdStmt
-
-checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
-checkCmdStmt _ (LastStmt x e s r) =
- checkCommand e >>= (\c -> return $ LastStmt x c s r)
-checkCmdStmt _ (BindStmt x pat e b f) =
- checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
-checkCmdStmt _ (BodyStmt x e t g) =
- checkCommand e >>= (\c -> return $ BodyStmt x c t g)
-checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
-checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
- ss <- mapM checkCmdLStmt stmts
- return $ stmt { recS_ext = noExt, recS_stmts = ss }
-checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
-checkCmdStmt l stmt = cmdStmtFail l stmt
-
-checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
- -> P (MatchGroup GhcPs (LHsCmd GhcPs))
-checkCmdMatchGroup mg@(MG { mg_alts = (dL->L l ms) }) = do
- ms' <- mapM (locMap $ const convert) ms
- return $ mg { mg_ext = noExt
- , mg_alts = cL l ms' }
- where convert match@(Match { m_grhss = grhss }) = do
- grhss' <- checkCmdGRHSs grhss
- return $ match { m_ext = noExt, m_grhss = grhss'}
- convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
-checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
-
-checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
-checkCmdGRHSs (GRHSs x grhss binds) = do
- grhss' <- mapM checkCmdGRHS grhss
- return $ GRHSs x grhss' binds
-checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
-
-checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
-checkCmdGRHS = locMap $ const convert
+ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
+ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
+
+ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
+ -> Located (b GhcPs) -> b GhcPs
+ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
where
- convert (GRHS x stmts e) = do
- c <- checkCommand e
--- cmdStmts <- mapM checkCmdLStmt stmts
- return $ GRHS x {- cmdStmts -} stmts c
- convert (XGRHS _) = panic "checkCmdGRHS"
+ cmdOpApp c1 op c2 =
+ let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
+ HsCmdArrForm noExt 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 }
+
+ecHsApp :: forall b. ExpCmdI b =>
+ Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
+ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
+
+ecHsIf :: forall b. ExpCmdI b =>
+ LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
+ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
+
+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 }
+
+ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
+ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
+
+{- Note [Ambiguous syntactic categories]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are places in the grammar where we do not know whether we are parsing an
+expression or a pattern without unlimited lookahead (which we do not have in
+'happy'):
+
+View patterns:
+
+ f (Con a b ) = ... -- 'Con a b' is a pattern
+ f (Con a b -> x) = ... -- 'Con a b' is an expression
+
+do-notation:
+
+ do { Con a b <- x } -- 'Con a b' is a pattern
+ do { Con a b } -- 'Con a b' is an expression
+
+Guards:
+
+ x | True <- p && q = ... -- 'True' is a pattern
+ x | True = ... -- 'True' is an expression
+
+Top-level value/function declarations (FunBind/PatBind):
+
+ f !a -- TH splice
+ f !a = ... -- function declaration
+
+ Until we encounter the = sign, we don't know if it's a top-level
+ TemplateHaskell splice where ! is an infix operator, or if it's a function
+ declaration where ! is a strictness annotation.
+
+There are also places in the grammar where we do not know whether we are
+parsing an expression or a command:
+
+ proc x -> do { (stuff) -< x } -- 'stuff' is an expression
+ proc x -> do { (stuff) } -- 'stuff' is a command
+
+ Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'
+ as an expression or a command.
+
+In fact, do-notation is subject to both ambiguities:
+
+ proc x -> do { (stuff) -< x } -- 'stuff' is an expression
+ proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern
+ proc x -> do { (stuff) } -- 'stuff' is a command
+
+There are many possible solutions to this problem. For an overview of the ones
+we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]
+
+The solution that keeps basic definitions (such as HsExpr) clean, keeps the
+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 a function from a GADT
+to a parser-validator:
+
+ data ExpCmdG b where
+ ExpG :: ExpCmdG HsExpr
+ CmdG :: ExpCmdG HsCmd
+
+ type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+
+ checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
+ checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
+ checkExp f = f ExpG -- interpret as an expression
+ checkCmd f = f CmdG -- interpret as a command
+
+Consider the 'alts' production used to parse case-of alternatives:
+
+ alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
+ : 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:
+
+ alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1
+ { \tag -> $1 tag >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts
+ { \tag -> $2 tag >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+Note that 'ExpCmdG' is a singleton type, the value is completely
+determined by the type:
+
+ when (b~HsExpr), tag = ExpG
+ when (b~HsCmd), tag = CmdG
+This is a clear indication that we can use a class to pass this value behind
+the scenes:
-cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
-cmdFail loc e = addFatalError loc (text "Parse error in command:" <+> ppr e)
-cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a
-cmdStmtFail loc e = addFatalError loc
- (text "Parse error in command statement:" <+> ppr e)
+ class ExpCmdI b where expCmdG :: ExpCmdG b
+ instance ExpCmdI HsExpr where expCmdG = ExpG
+ instance ExpCmdI HsCmd where expCmdG = CmdG
+
+And now the 'alts' production is simplified, as we no longer need to
+thread 'tag' explicitly:
+
+ alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : 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) }
+
+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
+
+The overhead is constant relative to the size of the rest of the reduction
+rule, so this approach scales well to large parser productions.
+
+-}
+
+
+{- Note [Resolving parsing ambiguities: non-taken alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Alternative I, extra constructors in HsExpr
+-------------------------------------------
+We could add extra constructors to HsExpr to represent command-specific and
+pattern-specific syntactic constructs. Under this scheme, we parse patterns
+and commands as expressions and rejig later. This is what GHC used to do, and
+it polluted 'HsExpr' with irrelevant constructors:
+
+ * for commands: 'HsArrForm', 'HsArrApp'
+ * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'
+
+(As of now, we still do that for patterns, but we plan to fix it).
+
+There are several issues with this:
+
+ * The implementation details of parsing are leaking into hsSyn definitions.
+
+ * Code that uses HsExpr has to panic on these impossible-after-parsing cases.
+
+ * HsExpr is arbitrarily selected as the extension basis. Why not extend
+ HsCmd or HsPat with extra constructors instead?
+
+ * We cannot handle corner cases. For instance, the following function
+ declaration LHS is not a valid expression (see Trac #1087):
+
+ !a + !b = ...
+
+ * There are points in the pipeline where the representation was awfully
+ incorrect. For instance,
+
+ f !a b !c = ...
+
+ is first parsed as
+
+ (f ! a b) ! c = ...
+
+
+Alternative II, extra constructors in HsExpr for GhcPs
+------------------------------------------------------
+We could address some of the problems with Alternative I by using Trees That
+Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to
+the output of parsing, not to its intermediate results, so we wouldn't want
+them there either.
+
+Alternative III, extra constructors in HsExpr for GhcPrePs
+----------------------------------------------------------
+We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.
+Unfortunately, creating a new pass would significantly bloat conversion code
+and slow down the compiler by adding another linear-time pass over the entire
+AST. For example, in order to build HsExpr GhcPrePs, we would need to build
+HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds
+GhcPrePs.
+
+
+Alternative IV, sum type and bottom-up data flow
+------------------------------------------------
+Expressions and commands are disjoint. There are no user inputs that could be
+interpreted as either an expression or a command depending on outer context:
+
+ 5 -- definitely an expression
+ x -< y -- definitely a command
+
+Even though we have both 'HsLam' and 'HsCmdLam', we can look at
+the body to disambiguate:
+
+ \p -> 5 -- definitely an expression
+ \p -> x -< y -- definitely a command
+
+This means we could use a bottom-up flow of information to determine
+whether we are parsing an expression or a command, using a sum type
+for intermediate results:
+
+ Either (LHsExpr GhcPs) (LHsCmd GhcPs)
+
+There are two problems with this:
+
+ * We cannot handle the ambiguity between expressions and
+ patterns, which are not disjoint.
+
+ * Bottom-up flow of information leads to poor error messages. Consider
+
+ if ... then 5 else (x -< y)
+
+ Do we report that '5' is not a valid command or that (x -< y) is not a
+ valid expression? It depends on whether we want the entire node to be
+ 'HsIf' or 'HsCmdIf', and this information flows top-down, from the
+ surrounding parsing context (are we in 'proc'?)
+
+Alternative V, backtracking with parser combinators
+---------------------------------------------------
+One might think we could sidestep the issue entirely by using a backtracking
+parser and doing something along the lines of (try pExpr <|> pPat).
+
+Turns out, this wouldn't work very well, as there can be patterns inside
+expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns
+(e.g. view patterns). To handle this, we would need to backtrack while
+backtracking, and unbound levels of backtracking lead to very fragile
+performance.
+
+Alternative VI, an intermediate data type
+-----------------------------------------
+There are common syntactic elements of expressions, commands, and patterns
+(e.g. all of them must have balanced parentheses), and we can capture this
+common structure in an intermediate data type, Frame:
+
+data Frame
+ = FrameVar RdrName
+ -- ^ Identifier: Just, map, BS.length
+ | FrameTuple [LTupArgFrame] Boxity
+ -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)
+ | FrameTySig LFrame (LHsSigWcType GhcPs)
+ -- ^ Type signature: x :: ty
+ | FramePar (SrcSpan, SrcSpan) LFrame
+ -- ^ Parentheses
+ | FrameIf LFrame LFrame LFrame
+ -- ^ If-expression: if p then x else y
+ | FrameCase LFrame [LFrameMatch]
+ -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
+ | FrameDo (HsStmtContext Name) [LFrameStmt]
+ -- ^ Do-expression: do { s1; a <- s2; s3 }
+ ...
+ | FrameExpr (HsExpr GhcPs) -- unambiguously an expression
+ | FramePat (HsPat GhcPs) -- unambiguously a pattern
+ | FrameCommand (HsCmd GhcPs) -- unambiguously a command
+
+To determine which constructors 'Frame' needs to have, we take the union of
+intersections between HsExpr, HsCmd, and HsPat.
+
+The intersection between HsPat and HsExpr:
+
+ HsPat = VarPat | TuplePat | SigPat | ParPat | ...
+ HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ...
+ -------------------------------------------------------------------
+ Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ...
+
+The intersection between HsCmd and HsExpr:
+
+ HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar
+ HsExpr = HsIf | HsCase | HsDo | HsPar
+ ------------------------------------------------
+ Frame = FrameIf | FrameCase | FrameDo | FramePar
+
+The intersection between HsCmd and HsPat:
+
+ HsPat = ParPat | ...
+ HsCmd = HsCmdPar | ...
+ -----------------------
+ Frame = FramePar | ...
+
+Take the union of each intersection and this yields the final 'Frame' data
+type. The problem with this approach is that we end up duplicating a good
+portion of hsSyn:
+
+ Frame for HsExpr, HsPat, HsCmd
+ TupArgFrame for HsTupArg
+ FrameMatch for Match
+ FrameStmt for StmtLR
+ FrameGRHS for GRHS
+ FrameGRHSs for GRHSs
+ ...
+
+Alternative VII, a product type
+-------------------------------
+We could avoid the intermediate representation of Alternative VI by parsing
+into a product of interpretations directly:
+
+ -- See Note [Parser-Validator]
+ type ExpCmdPat = ( PV (LHsExpr GhcPs)
+ , PV (LHsCmd GhcPs)
+ , PV (LHsPat GhcPs) )
+
+This means that in positions where we do not know whether to produce
+expression, a pattern, or a command, we instead produce a parser-validator for
+each possible option.
+
+Then, as soon as we have parsed far enough to resolve the ambiguity, we pick
+the appropriate component of the product, discarding the rest:
+
+ checkExpOf3 (e, _, _) = e -- interpret as an expression
+ checkCmdOf3 (_, c, _) = c -- interpret as a command
+ checkPatOf3 (_, _, p) = p -- interpret as a pattern
+
+We can easily define ambiguities between arbitrary subsets of interpretations.
+For example, when we know ahead of type that only an expression or a command is
+possible, but not a pattern, we can use a smaller type:
+
+ -- See Note [Parser-Validator]
+ type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))
+
+ checkExpOf2 (e, _) = e -- interpret as an expression
+ checkCmdOf2 (_, c) = c -- interpret as a command
+
+However, there is a slight problem with this approach, namely code duplication
+in parser productions. Consider the 'alts' production used to parse case-of
+alternatives:
+
+ alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
+ : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+Under the new scheme, we have to completely duplicate its type signature and
+each reduction rule:
+
+ alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression
+ , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command
+ ) }
+ : alts1
+ { ( checkExpOf2 $1 >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
+ , checkCmdOf2 $1 >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)
+ ) }
+ | ';' alts
+ { ( checkExpOf2 $2 >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
+ , checkCmdOf2 $2 >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)
+ ) }
+
+And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
+'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
+
+-}
---------------------------------------------------------------------------
-- Miscellaneous utilities
@@ -2306,6 +2676,38 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
-----------------------------------------------------------------------------
-- Misc utils
+type PV = P -- See Note [Parser-Validator]
+
+{- Note [Parser-Validator]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When resolving ambiguities, we need to postpone failure to make a choice later.
+For example, if we have ambiguity between some A and B, our parser could be
+
+ abParser :: P (Maybe A, Maybe B)
+
+This way we can represent four possible outcomes of parsing:
+
+ (Just a, Nothing) -- definitely A
+ (Nothing, Just b) -- definitely B
+ (Just a, Just b) -- either A or B
+ (Nothing, Nothing) -- neither A nor B
+
+However, if we want to report informative parse errors, accumulate warnings,
+and add API annotations, we are better off using 'P' instead of 'Maybe':
+
+ abParser :: P (P A, P B)
+
+So we have an outer layer of P that consumes the input and builds the inner
+layer, which validates the input.
+
+For clarity, we introduce the notion of a parser-validator: a parser that does
+not consume any input, but may fail or use other effects. Thus we have:
+
+ abParser :: P (PV A, PV B)
+
+-}
+
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat span e = do
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index c74e46df97..bed53ece35 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -412,24 +412,12 @@ rnExpr (HsProc x pat body)
{ (body',fvBody) <- rnCmdTop body
; return (HsProc x pat' body', fvBody) }
--- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
-rnExpr e@(HsArrApp {}) = arrowFail e
-rnExpr e@(HsArrForm {}) = arrowFail e
-
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
-arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-arrowFail e
- = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
- , nest 2 (ppr e) ])
- -- Return a place-holder hole, so that we can carry on
- -- to report other errors
- ; return (hsHoleExpr, emptyFVs) }
-
----------------------
-- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 3a7ab5b10b..797a421956 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3664,8 +3664,6 @@ exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp"
-exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
diff --git a/hadrian/src/Settings/Builders/Happy.hs b/hadrian/src/Settings/Builders/Happy.hs
index 5ffb2614cc..edb520cdf3 100644
--- a/hadrian/src/Settings/Builders/Happy.hs
+++ b/hadrian/src/Settings/Builders/Happy.hs
@@ -3,7 +3,7 @@ module Settings.Builders.Happy (happyBuilderArgs) where
import Settings.Builders.Common
happyBuilderArgs :: Args
-happyBuilderArgs = builder Happy ? mconcat [ arg "-agc"
+happyBuilderArgs = builder Happy ? mconcat [ arg "-ag" -- TODO (int-index): restore the -c option when happy/pull/134 is merged.
, arg "--strict"
, arg =<< getInput
, arg "-o", arg =<< getOutput ]
diff --git a/mk/config.mk.in b/mk/config.mk.in
index 0119e9a984..2bff8432e4 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -852,7 +852,8 @@ HAPPY_VERSION = @HappyVersion@
#
# Options to pass to Happy when we're going to compile the output with GHC
#
-SRC_HAPPY_OPTS = -agc --strict
+# TODO (int-index): restore the -c option when happy/pull/134 is merged.
+SRC_HAPPY_OPTS = -ag --strict
#
# Alex
diff --git a/testsuite/tests/ghci/scripts/T8959.stderr b/testsuite/tests/ghci/scripts/T8959.stderr
index 2890a172c2..fae95f7327 100644
--- a/testsuite/tests/ghci/scripts/T8959.stderr
+++ b/testsuite/tests/ghci/scripts/T8959.stderr
@@ -1,7 +1,19 @@
<interactive>:1:1: error:
Arrow command found where an expression was expected:
- () >- () -< () >>- () -<< ()
+ () >- _
+
+<interactive>:1:7: error:
+ Arrow command found where an expression was expected:
+ () -< _
+
+<interactive>:1:13: error:
+ Arrow command found where an expression was expected:
+ () >>- _
+
+<interactive>:1:20: error:
+ Arrow command found where an expression was expected:
+ () -<< ()
<interactive>:8:15: error:
• Couldn't match expected type ‘()’ with actual type ‘Bool’
@@ -13,7 +25,19 @@
<interactive>:1:1: error:
Arrow command found where an expression was expected:
- () ⤚ () ⤙ () ⤜ () ⤛ ()
+ () ⤚ _
+
+<interactive>:1:7: error:
+ Arrow command found where an expression was expected:
+ () ⤙ _
+
+<interactive>:1:13: error:
+ Arrow command found where an expression was expected:
+ () ⤜ _
+
+<interactive>:1:20: error:
+ Arrow command found where an expression was expected:
+ () ⤛ ()
<interactive>:15:15: error:
• Couldn't match expected type ‘()’ with actual type ‘Bool’
@@ -25,7 +49,19 @@
<interactive>:1:1: error:
Arrow command found where an expression was expected:
- () >- () -< () >>- () -<< ()
+ () >- _
+
+<interactive>:1:7: error:
+ Arrow command found where an expression was expected:
+ () -< _
+
+<interactive>:1:13: error:
+ Arrow command found where an expression was expected:
+ () >>- _
+
+<interactive>:1:20: error:
+ Arrow command found where an expression was expected:
+ () -<< ()
<interactive>:22:15: error:
• Couldn't match expected type ‘()’ with actual type ‘Bool’
View Lorry Controller Status