summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
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