WIP: ECFramewip/exp-cmd-frame

3 files changed, 290 insertions, 140 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index c4d0d4d127..0606c56297 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -57,7 +57,7 @@ module Lexer (
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..), getBit,
-   addWarning,
+   addWarning, addError,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
    commentToAnnotation
@@ -2479,6 +2479,17 @@ mkPStatePure options buf loc =
       annotations_comments = []
     }
 
+addError :: SrcSpan -> SDoc -> P ()
+addError srcspan msg
+ = P $ \s@PState{messages=m} ->
+       let
+           m' d =
+               let (ws, es) = m d
+                   errormsg = mkErrMsg d srcspan alwaysQualify msg
+                   es' = es `snocBag` errormsg
+               in (ws, es')
+       in POk s{messages=m'} ()
+
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=m, options=o} ->
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index ce5c523e6f..c4f4b408b4 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -33,7 +33,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 )
@@ -1505,7 +1505,7 @@ decl_cls  : at_decl_cls                 { $1 }
 
           -- A 'default' signature used with the generic-programming extension
           | 'default' infixexp '::' sigtypedoc
-                    {% do { v <- checkValSigLhs $2
+                    {% do { v <- (checkValSigLhs <=< ecfToExpr) $2
                           ; let err = text "in default signature" <> colon <+>
                                       quotes (ppr $2)
                           ; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4)
@@ -1644,11 +1644,13 @@ rules   :: { OrdList (LRuleDecl GhcPs) }
 
 rule    :: { LRuleDecl GhcPs }
         : STRING rule_activation rule_foralls infixexp '=' exp
-         {%ams (sLL $1 $> $ HsRule { rd_ext = noExt
+         {% ecfToExpr $4 >>= \e4 ->
+            ecfToExpr $6 >>= \e6 ->
+            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
-                                   , rd_lhs = $4, rd_rhs = $6 })
+                                   , rd_lhs = e4, rd_rhs = e6 })
                (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
 
 -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1753,19 +1755,22 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
 -----------------------------------------------------------------------------
 -- Annotations
 annotation :: { LHsDecl GhcPs }
-    : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+    : '{-# ANN' name_var aexp '#-}'      {% ecfToExpr $3 >>= \e3 ->
+                                            ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                             (getANN_PRAGs $1)
-                                            (ValueAnnProvenance $2) $3))
+                                            (ValueAnnProvenance $2) e3))
                                             [mo $1,mc $4] }
 
-    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+    | '{-# ANN' 'type' tycon aexp '#-}'  {% ecfToExpr $4 >>= \e4 ->
+                                            ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                             (getANN_PRAGs $1)
-                                            (TypeAnnProvenance $3) $4))
+                                            (TypeAnnProvenance $3) e4))
                                             [mo $1,mj AnnType $2,mc $5] }
 
-    | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
+    | '{-# ANN' 'module' aexp '#-}'      {% ecfToExpr $3 >>= \e3 ->
+                                            ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                                 (getANN_PRAGs $1)
-                                                 ModuleAnnProvenance $3))
+                                                 ModuleAnnProvenance e3))
                                                 [mo $1,mj AnnModule $2,mc $4] }
 
 
@@ -2373,10 +2378,11 @@ 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          {% do { e2 <- ecfToExpr $2 ;
+                                        let { e = sLL $1 e2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) e2)
                                             ; l = comb2 $1 $> };
                                         (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
-                                        hintBangPat (comb2 $1 $2) (unLoc e) ;
+                                        hintBangPat (comb2 $1 e2) (unLoc e) ;
                                         -- Depending upon what the pattern looks like we might get either
                                         -- a FunBind or PatBind back from checkValDef. See Note
                                         -- [FunBind vs PatBind]
@@ -2413,9 +2419,10 @@ 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    {% ecfToExpr $2 >>= \e2 ->
+                                  return $ sL (comb3 $1 $2 $3)
                                     ((mj AnnEqual $1 : (fst $ unLoc $3))
-                                    ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2)
+                                    ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) e2)
                                    (snd $ unLoc $3)) }
         | gdrhs wherebinds      { sLL $1 $>  (fst $ unLoc $2
                                     ,GRHSs noExt (reverse (unLoc $1))
@@ -2426,7 +2433,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  {% ecfToExpr $4 >>= \e4 ->
+                                     ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) e4)
                                          [mj AnnVbar $1,mj AnnEqual $3] }
 
 sigdecl :: { LHsDecl GhcPs }
@@ -2525,59 +2533,78 @@ 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   :: { LExpCmdFrame }
+        : infixexp '::' sigtype {% ecfToExpr $1 >>= \e1 ->
+                                   ams (sLL $1 $> $ ECFrameExp $ ExprWithTySig noExt e1 (mkLHsSigWcType $3))
                                        [mu AnnDcolon $2] }
-        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
+        | infixexp '-<' exp     {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                   ams (sLL $1 $> $ ECFrameCmd $ HsCmdArrApp noExt e1 e3
                                                         HsFirstOrderApp True)
                                        [mu Annlarrowtail $2] }
-        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
+        | infixexp '>-' exp     {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                   ams (sLL $1 $> $ ECFrameCmd $ HsCmdArrApp noExt e3 e1
                                                       HsFirstOrderApp False)
                                        [mu Annrarrowtail $2] }
-        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
+        | infixexp '-<<' exp    {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                   ams (sLL $1 $> $ ECFrameCmd $ HsCmdArrApp noExt e1 e3
                                                       HsHigherOrderApp True)
                                        [mu AnnLarrowtail $2] }
-        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
+        | infixexp '>>-' exp    {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                   ams (sLL $1 $> $ ECFrameCmd $ HsCmdArrApp noExt e3 e1
                                                       HsHigherOrderApp False)
                                        [mu AnnRarrowtail $2] }
         | infixexp              { $1 }
 
-infixexp :: { LHsExpr GhcPs }
+infixexp :: { LExpCmdFrame }
         : exp10 { $1 }
-        | infixexp qop exp10  {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
+        | infixexp qop exp10  {% ecfToExpr $1 >>= \e1 ->
+                                 ecfToExpr $3 >>= \e3 ->
+                                 ams (sLL $1 $> (ECFrameExp $ OpApp noExt e1 $2 e3))
                                      [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
 infixexp_top :: { LHsExpr GhcPs }
-            : exp10_top               { $1 }
+            : exp10_top               {% ecfToExpr $1 }
             | infixexp_top qop exp10_top
                                       {% do { when (srcSpanEnd (getLoc $2)
                                                 == srcSpanStart (getLoc $3)
                                                 && checkIfBang $2) $
                                                 warnSpaceAfterBang (comb2 $2 $3);
-                                              ams (sLL $1 $> (OpApp noExt $1 $2 $3))
-                                                   [mj AnnVal $2]
+                                              ecfToExpr $3 >>= \e3 ->
+                                                ams (sLL $1 $> (OpApp noExt $1 $2 e3))
+                                                     [mj AnnVal $2]
                                             }
                                       }
 
-exp10_top :: { LHsExpr GhcPs }
-        : '-' fexp                      {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
+exp10_top :: { LExpCmdFrame }
+        : '-' fexp                      {% ecfToExpr $2 >>= \e2 ->
+                                           ams (sLL $1 $> $ ECFrameExp $ NegApp noExt e2 noSyntaxExpr)
                                                [mj AnnMinus $1] }
 
 
-        | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
-                                                                (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+        | hpc_annot exp        {% ecfToExpr $2 >>= \e2 ->
+                                  ams (sLL $1 $> $ ECFrameExp
+                                                 $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
+                                                                (snd $ fst $ unLoc $1) (snd $ unLoc $1) e2)
                                       (fst $ fst $ fst $ unLoc $1) }
 
-        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+        | '{-# CORE' STRING '#-}' exp  {% ecfToExpr $4 >>= \e4 ->
+                                          ams (sLL $1 $> $ ECFrameExp $
+                                            HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) e4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
                                           -- hdaume: core annotation
         | fexp                         { $1 }
 
-exp10 :: { LHsExpr GhcPs }
+exp10 :: { LExpCmdFrame }
         : exp10_top            { $1 }
-        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+        | scc_annot exp        {% ecfToExpr $2 >>= \e2 ->
+                                  ams (sLL $1 $> $ ECFrameExp $
+                                        HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) e2)
                                       (fst $ fst $ unLoc $1) }
 
 optSemi :: { ([Located a],Bool) }
@@ -2619,129 +2646,148 @@ 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 >>
-                                        ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
+fexp    :: { LExpCmdFrame }
+        : fexp aexp                  {% ecfToExpr $1 >>= \e1 ->
+                                        ecfToExpr $2 >>= \e2 ->
+                                        checkBlockArguments e1 >> checkBlockArguments e2 >>
+                                        return (sLL $1 $> $ ECFrameExp $ HsApp noExt e1 e2) }
+        | fexp TYPEAPP atype         {% ecfToExpr $1 >>= \e1 ->
+                                        checkBlockArguments e1 >>
+                                        ams (sLL $1 $> $ ECFrameExp $ HsAppType noExt e1 (mkHsWildCardBndrs $3))
                                             [mj AnnAt $2] }
-        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic noExt $2)
+        | 'static' aexp              {% ecfToExpr $2 >>= \e2 ->
+                                        ams (sLL $1 $> $ ECFrameExp $ HsStatic noExt e2)
                                             [mj AnnStatic $1] }
         | aexp                       { $1 }
 
-aexp    :: { LHsExpr GhcPs }
-        : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
+aexp    :: { LExpCmdFrame }
+        : qvar '@' aexp         {% ecfToExpr $3 >>= \e3 ->
+                                   ams (sLL $1 $> $ ECFrameExp $ EAsPat noExt $1 e3) [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              {% ecfToExpr $2 >>= \e2 ->
+                                   ams (sLL $1 $> $ ECFrameExp $ ELazyPat noExt e2) [mj AnnTilde $1] }
 
         | '\\' apat apats '->' exp
-                   {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource
+                   {% ecfToExpr $5 >>= \e5 ->
+                      ams (sLL $1 $> $ ECFrameExp $ HsLam noExt (mkMatchGroup FromSource
                             [sLL $1 $> $ Match { m_ext = noExt
                                                , m_ctxt = LambdaExpr
                                                , m_pats = $2:$3
-                                               , m_grhss = unguardedGRHSs $5 }]))
+                                               , m_grhss = unguardedGRHSs e5 }]))
                           [mj AnnLam $1, mu AnnRarrow $4] }
-        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4)
+        | 'let' binds 'in' exp          {% ecfToExpr $4 >>= \e4 ->
+                                           ams (sLL $1 $> $ ECFrameExp $ HsLet noExt (snd $ unLoc $2) e4)
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
         | '\\' 'lcase' altslist
-            {% ams (sLL $1 $> $ HsLamCase noExt
+            {% ams (sLL $1 $> $ ECFrameExp $ 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)
+                           {% ecfToExpr $2 >>= \e2 ->
+                              ecfToExpr $5 >>= \e5 ->
+                              ecfToExpr $8 >>= \e8 ->
+                              checkDoAndIfThenElse e2 (snd $3) e5 (snd $6) e8 >>
+                              ams (sLL $1 $> $ ECFrameExp $ mkHsIf e2 e5 e8)
                                   (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) >>
-                                           ams (sLL $1 $> $ HsMultiIf noExt
+                                           ams (sLL $1 $> $ ECFrameExp $ 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      {% ecfToExpr $2 >>= \e2 ->
+                                           ams (cL (comb3 $1 $3 $4) $
+                                                   ECFrameExp $
+                                                   HsCase noExt e2 (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)))
+                                               (ECFrameExp $ mkHsDo DoExpr (snd $ unLoc $2)))
                                                (mj AnnDo $1:(fst $ unLoc $2)) }
         | 'mdo' stmtlist            {% ams (cL (comb2 $1 $2)
-                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
+                                              (ECFrameExp $ mkHsDo MDoExpr (snd $ unLoc $2)))
                                            (mj AnnMdo $1:(fst $ unLoc $2)) }
         | 'proc' aexp '->' exp
-                       {% checkPattern empty $2 >>= \ p ->
-                           checkCommand $4 >>= \ cmd ->
-                           ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
+                       {% (checkPattern empty <=< ecfToExpr) $2 >>= \ p ->
+                           ecfToCommand $4 >>= \ cmd ->
+                           ams (sLL $1 $> $ ECFrameExp $ 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   :: { LExpCmdFrame }
+        : aexp1 '{' fbinds '}' {% do { e1 <- ecfToExpr $1
+                                     ; r <- mkRecConstrOrUpdate e1 (comb2 $2 $4)
                                                                    (snd $3)
-                                     ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3))
-                                     ; checkRecordSyntax (sLL $1 $> r) }}
+                                     ; _ <- amsL (comb2 e1 $>) (moc $2:mcc $4:(fst $3))
+                                     ; checkRecordSyntax (sLL e1 $> (ECFrameExp 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   :: { LExpCmdFrame }
+        : qvar                          { sL1 $1 (ECFrameExp $ HsVar noExt   $! $1) }
+        | qcon                          { sL1 $1 (ECFrameExp $ HsVar noExt   $! $1) }
+        | ipvar                         { sL1 $1 (ECFrameExp $ HsIPVar noExt $! unLoc $1) }
+        | overloaded_label              { sL1 $1 (ECFrameExp $ HsOverLabel noExt Nothing $! unLoc $1) }
+        | literal                       { sL1 $1 (ECFrameExp $ 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   { sL (getLoc $1) (ECFrameExp $ HsOverLit noExt $! mkHsIntegral   (getINTEGER $1) ) }
+        | RATIONAL  { sL (getLoc $1) (ECFrameExp $ 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 ')'                  {% ecfToExpr $2 >>= \e2 ->
+                                           ams (sLL $1 $> (ECFrameExp $ HsPar noExt e2)) [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]) } }
+                                              ; ams (sLL $1 $> $ ECFrameExp e) ((mop $1:fst $2) ++ [mcp $3]) } }
 
-        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2)
-                                                         (Present noExt $2)] Unboxed))
+        | '(#' texp '#)'                {% ecfToExpr $2 >>= \e2 ->
+                                           ams (sLL $1 $> (ECFrameExp $ ExplicitTuple noExt [cL (gl $2)
+                                                         (Present noExt e2)] 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]) } }
+                                              ; ams (sLL $1 $> (ECFrameExp e)) ((mo $1:fst $2) ++ [mc $3]) } }
 
-        | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
-        | '_'               { sL1 $1 $ EWildPat noExt }
+        | '[' list ']'      {% ams (sLL $1 $> (ECFrameExp $ snd $2)) (mos $1:mcs $3:(fst $2)) }
+        | '_'               { sL1 $1 $ ECFrameExp $ EWildPat noExt }
 
         -- Template Haskell Extension
-        | splice_exp            { $1 }
+        | splice_exp            { mapLoc ECFrameExp $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     {% ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ ECFrameExp $ 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 '|]'       {% ecfToExpr $2 >>= \e2 ->
+                                 ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (ExpBr noExt e2))
                                       (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 '||]'     {% ecfToExpr $2 >>= \e2 ->
+                                 ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (TExpBr noExt e2))
                                       (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 ->
-                                      ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
+        | '[t|' ktype '|]'    {% ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
+        | '[p|' infixexp '|]' {% (checkPattern empty <=< ecfToExpr) $2 >>= \p ->
+                                      ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (PatBr noExt p))
                                           [mo $1,mu AnnCloseQ $3] }
-        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
+        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ ECFrameExp $ HsBracket noExt (DecBrL noExt (snd $2)))
                                       (mo $1:mu AnnCloseQ $3:fst $2) }
-        | quasiquote          { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
+        | quasiquote          { sL1 $1 (ECFrameExp $ HsSpliceE noExt (unLoc $1)) }
 
         -- arrow notation extension
-        | '(|' aexp2 cmdargs '|)'  {% ams (sLL $1 $> $ HsArrForm noExt $2
-                                                           Nothing (reverse $3))
+        | '(|' aexp2 cmdargs '|)'  {% ecfToExpr $2 >>= \e ->
+                                      ams (sLL $1 $> $ ECFrameCmd $
+                                             HsCmdArrForm noExt e Prefix Nothing (reverse $3))
                                           [mu AnnOpenB $1,mu AnnCloseB $4] }
 
 splice_exp :: { LHsExpr GhcPs }
@@ -2753,7 +2799,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 ')'          {% ecfToExpr $2 >>= \e2 ->
+                                   ams (sLL $1 $> $ mkUntypedSplice HasParens e2)
                                        [mj AnnOpenPE $1,mj AnnCloseP $3] }
 
 splice_typed :: { Located (HsSplice GhcPs) }
@@ -2761,7 +2808,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 ')'         {% ecfToExpr $2 >>= \e2 ->
+                                    ams (sLL $1 $> $ mkTypedSplice HasParens e2)
                                        [mj AnnOpenPTE $1,mj AnnCloseP $3] }
 
 cmdargs :: { [LHsCmdTop GhcPs] }
@@ -2769,7 +2817,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
         | {- empty -}                   { [] }
 
 acmd    :: { LHsCmdTop GhcPs }
-        : aexp2                 {% checkCommand $1 >>= \ cmd ->
+        : aexp2                 {% ecfToCommand $1 >>= \ cmd ->
                                     return (sL1 $1 $ HsCmdTop noExt cmd) }
 
 cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
@@ -2787,7 +2835,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 :: { LExpCmdFrame }
         : exp                           { $1 }
 
         -- Note [Parsing sections]
@@ -2801,19 +2849,25 @@ 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        {% ecfToExpr $1 >>= \e1 ->
+                                 return $ sLL $1 $> $ ECFrameExp $ SectionL noExt e1 $2 }
+        | qopm infixexp       {% ecfToExpr $2 >>= \e2 ->
+                                 return $ sLL $1 $> $ ECFrameExp $ SectionR noExt $1 e2 }
 
        -- View patterns get parenthesized above
-        | exp '->' texp   {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
+        | exp '->' texp   {% ecfToExpr $1 >>= \e1 ->
+                             ecfToExpr $3 >>= \e3 ->
+                             ams (sLL $1 $> $ ECFrameExp $ EViewPat noExt e1 e3) [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)
-                                ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
+                          {% ecfToExpr $1 >>= \e1 ->
+                             do { addAnnotation (gl $1) AnnComma (fst $2)
+                                ; return ([],Tuple ((sL1 $1 (Present noExt e1)) : snd $2)) } }
 
-           | texp bars    { (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }
+           | texp bars    {% ecfToExpr $1 >>= \e1 ->
+                             return (mvbars (fst $2), Sum 1  (snd $2 + 1) e1) }
 
            | commas tup_tail
                 {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)
@@ -2821,7 +2875,9 @@ 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) }
+                {% ecfToExpr $2 >>= \e2 ->
+                   return (mvbars (fst $1) ++ mvbars (fst $3),
+                           Sum (snd $1 + 1) (snd $1 + snd $3 + 1) e2) }
 
 -- Always starts with commas; always follows an expr
 commas_tup_tail :: { (SrcSpan,[LHsTupArg GhcPs]) }
@@ -2833,9 +2889,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) >>
-                                    return ((cL (gl $1) (Present noExt $1)) : snd $2) }
-          | texp                 { [cL (gl $1) (Present noExt $1)] }
+          : texp commas_tup_tail {% ecfToExpr $1 >>= \e1 ->
+                                    addAnnotation (gl $1) AnnComma (fst $2) >>
+                                    return ((cL (gl $1) (Present noExt e1)) : snd $2) }
+          | texp                 {% ecfToExpr $1 >>= \e1 ->
+                                    return [cL (gl $1) (Present noExt e1)] }
           | {- empty -}          { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
@@ -2844,30 +2902,43 @@ 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    {% ecfToExpr $1 >>= \e1 ->
+                     return ([],ExplicitList noExt Nothing [e1]) }
         | lexps   { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) }
-        | texp '..'             { ([mj AnnDotdot $2],
-                                      ArithSeq noExt Nothing (From $1)) }
-        | texp ',' exp '..'     { ([mj AnnComma $2,mj AnnDotdot $4],
+        | texp '..'             {% ecfToExpr $1 >>= \e1 ->
+                                  return ([mj AnnDotdot $2],
+                                      ArithSeq noExt Nothing (From e1)) }
+        | texp ',' exp '..'     {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                  return ([mj AnnComma $2,mj AnnDotdot $4],
                                   ArithSeq noExt Nothing
-                                                             (FromThen $1 $3)) }
-        | texp '..' exp         { ([mj AnnDotdot $2],
+                                                             (FromThen e1 e3)) }
+        | texp '..' exp         {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                  return ([mj AnnDotdot $2],
                                    ArithSeq noExt Nothing
-                                                               (FromTo $1 $3)) }
-        | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
+                                                               (FromTo e1 e3)) }
+        | texp ',' exp '..' exp {% ecfToExpr $1 >>= \e1 ->
+                                   ecfToExpr $3 >>= \e3 ->
+                                   ecfToExpr $5 >>= \e5 ->
+                                  return ([mj AnnComma $2,mj AnnDotdot $4],
                                     ArithSeq noExt Nothing
-                                                (FromThenTo $1 $3 $5)) }
+                                                (FromThenTo e1 e3 e5)) }
         | texp '|' flattenedpquals
              {% checkMonadComp >>= \ ctxt ->
+                ecfToExpr $1 >>= \e1 ->
                 return ([mj AnnVbar $2],
-                        mkHsComp ctxt (unLoc $3) $1) }
+                        mkHsComp ctxt (unLoc $3) e1) }
 
 lexps :: { Located [LHsExpr GhcPs] }
-        : lexps ',' texp          {% addAnnotation (gl $ head $ unLoc $1)
+        : lexps ',' texp          {% ecfToExpr $3 >>= \e3 ->
+                                     addAnnotation (gl $ head $ unLoc $1)
                                                             AnnComma (gl $2) >>
-                                      return (sLL $1 $> (((:) $! $3) $! unLoc $1)) }
-        | texp ',' texp            {% addAnnotation (gl $1) AnnComma (gl $2) >>
-                                      return (sLL $1 $> [$3,$1]) }
+                                      return (sLL $1 $> (((:) $! e3) $! unLoc $1)) }
+        | texp ',' texp            {% ecfToExpr $1 >>= \e1 ->
+                                      ecfToExpr $3 >>= \e3 ->
+                                      addAnnotation (gl $1) AnnComma (gl $2) >>
+                                      return (sLL $1 $> [e3,e1]) }
 
 -----------------------------------------------------------------------------
 -- List Comprehensions
@@ -2913,13 +2984,23 @@ 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              {% ecfToExpr $2 >>= \e2 ->
+                                 return $ sLL $1 $> ([mj AnnThen $1],
+                                                     \ss -> (mkTransformStmt ss e2)) }
+    | 'then' exp 'by' exp     {% ecfToExpr $2 >>= \e2 ->
+                                 ecfToExpr $4 >>= \e4 ->
+                                 return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy  $3],
+                                                     \ss -> (mkTransformByStmt ss e2 e4)) }
     | 'then' 'group' 'using' exp
-             { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) }
+            {% ecfToExpr $4 >>= \e4 ->
+               return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3],
+                                   \ss -> (mkGroupUsingStmt ss e4)) }
 
     | '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)) }
+            {% ecfToExpr $4 >>= \e4 ->
+               ecfToExpr $6 >>= \e6 ->
+               return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5],
+                                   \ss -> (mkGroupByUsingStmt ss e4 e6)) }
 
 -- Note that 'group' is a special_id, which means that you can enable
 -- TransformListComp while still using Data.List.group. However, this
@@ -2981,7 +3062,8 @@ alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
                                             GRHSs noExt (unLoc $1) (snd $ unLoc $2)) }
 
 ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
-        : '->' exp            {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
+        : '->' exp            {% ecfToExpr $2 >>= \e2 ->
+                                 ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) e2))
                                      [mu AnnRarrow $1] }
         | gdpats              { sL1 $1 (reverse (unLoc $1)) }
 
@@ -2998,7 +3080,8 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
 
 gdpat   :: { LGRHS GhcPs (LHsExpr GhcPs) }
         : '|' guardquals '->' exp
-                                  {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
+                                  {% ecfToExpr $4 >>= \e4 ->
+                                     ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) e4)
                                          [mj AnnVbar $1,mu AnnRarrow $3] }
 
 -- 'pat' recognises a pattern, including one with a bang at the top
@@ -3006,24 +3089,28 @@ 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
-                                                     (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+pat     :  exp          {% (checkPattern empty <=< ecfToExpr) $1 }
+        | '!' aexp      {% ecfToExpr $2 >>= \e2 ->
+                           amms (checkPattern empty (sLL $1 $> (SectionR noExt
+                                                     (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) e2)))
                                 [mj AnnBang $1] }
 
 bindpat :: { LPat GhcPs }
-bindpat :  exp            {% checkPattern
-                                (text "Possibly caused by a missing 'do'?") $1 }
-        | '!' aexp        {% amms (checkPattern
+bindpat :  exp            {% ecfToExpr $1 >>=
+                             checkPattern
+                                (text "Possibly caused by a missing 'do'?") }
+        | '!' aexp        {% ecfToExpr $2 >>= \e2 ->
+                             amms (checkPattern
                                      (text "Possibly caused by a missing 'do'?")
-                                     (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+                                     (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) e2)))
                                   [mj AnnBang $1] }
 
 apat   :: { LPat GhcPs }
-apat    : aexp                  {% checkPattern empty $1 }
-        | '!' aexp              {% amms (checkPattern empty
+apat    : aexp                  {% (checkPattern empty <=< ecfToExpr) $1 }
+        | '!' aexp              {% ecfToExpr $2 >>= \e2 ->
+                                   amms (checkPattern empty
                                             (sLL $1 $> (SectionR noExt
-                                                (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
+                                                (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) e2)))
                                         [mj AnnBang $1] }
 
 apats  :: { [LPat GhcPs] }
@@ -3075,9 +3162,11 @@ stmt  :: { LStmt GhcPs (LHsExpr GhcPs) }
                                                (mj AnnRec $1:(fst $ unLoc $2)) }
 
 qual  :: { LStmt GhcPs (LHsExpr GhcPs) }
-    : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)
+    : bindpat '<-' exp                  {% ecfToExpr $3 >>= \e3 ->
+                                           ams (sLL $1 $> $ mkBindStmt $1 e3)
                                                [mu AnnLarrow $2] }
-    | exp                               { sL1 $1 $ mkBodyStmt $1 }
+    | exp                               {% ecfToExpr $1 >>= \e1 ->
+                                           return (sL1 $1 $ mkBodyStmt e1) }
     | 'let' binds                       {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2))
                                                (mj AnnLet $1:(fst $ unLoc $2)) }
 
@@ -3096,7 +3185,8 @@ fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) }
         | '..'                          { ([mj AnnDotdot $1],([],   True)) }
 
 fbind   :: { LHsRecField GhcPs (LHsExpr GhcPs) }
-        : qvar '=' texp {% ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
+        : qvar '=' texp {% ecfToExpr $3 >>= \e3 ->
+                           ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) e3 False)
                                 [mj AnnEqual $2] }
                         -- RHS is a 'texp', allowing view patterns (Trac #6038)
                         -- and, incidentally, sections.  Eg
@@ -3120,7 +3210,8 @@ dbinds  :: { Located [LIPBind GhcPs] }
 --      | {- empty -}                  { [] }
 
 dbind   :: { LIPBind GhcPs }
-dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind noExt (Left $1) $3))
+dbind   : ipvar '=' exp                {% ecfToExpr $3 >>= \e3 ->
+                                          ams (sLL $1 $> (IPBind noExt (Left $1) e3))
                                               [mj AnnEqual $2] }
 
 ipvar   :: { Located HsIPName }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 45fc5a0972..9374dad545 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -51,7 +51,6 @@ module   RdrHsSyn (
         bang_RDR,
         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
         checkMonadComp,       -- P (HsStmtContext RdrName)
-        checkCommand,         -- LHsExpr RdrName -> P (LHsCmd RdrName)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
         checkDoAndIfThenElse,
@@ -75,7 +74,14 @@ module   RdrHsSyn (
         warnStarIsType,
         failOpFewArgs,
 
-        SumOrTuple (..), mkSumOrTuple
+        SumOrTuple (..), mkSumOrTuple,
+
+        -- Expression/command frame
+        ECFrame(..),
+        ExpCmdFrame,
+        LExpCmdFrame,
+        ecfToCommand,
+        ecfToExpr,
 
     ) where
 
@@ -1856,6 +1862,48 @@ checkMonadComp = do
 -- We parse arrow syntax as expressions and check for valid syntax below,
 -- converting the expression into a pattern at the same time.
 
+-- | Expression/command frame.
+data ECFrame e c
+  = ECFrameExp e
+  | ECFrameCmd c
+  | ECFrameAmb e c
+
+instance (Outputable e, Outputable c) => Outputable (ECFrame e c) where
+  ppr (ECFrameExp e) = ppr e
+  ppr (ECFrameCmd c) = ppr c
+  ppr (ECFrameAmb e _) = ppr e
+
+type ExpCmdFrame = ECFrame (HsExpr GhcPs) (HsCmd GhcPs)
+type LExpCmdFrame = Located ExpCmdFrame
+{-
+type ExpCmdStmtFrame = ECFrame (ExprStmt GhcPs) (CmdStmt GhcPs)
+type ExpCmdMatchGroupFrame = ECFrame (MatchGroup GhcPs (LHsExpr GhcPs)) (MatchGroup GhcPs (LHsCmd GhcPs))
+-}
+
+ecfToCommand :: LExpCmdFrame -> P (LHsCmd GhcPs)
+ecfToCommand (dL->L l a) =
+  case a of
+    ECFrameCmd c -> return (cL l c)
+    ECFrameAmb _ c -> return (cL l c)
+    ECFrameExp e -> -- checkCommand (cL l e) -- FIXME (int-index)
+      parseErrorSDoc l (text "Parse error in command:" <+> ppr e)
+
+-- TEST="T3822 T3964 T5022 T5283 T5333 T5380 arrowcase1 arrowdo1 arrowdo2 arrowfail001 arrowfail003 arrowfail004 arrowform1 arrowif1 arrowlet1 arrowpat arrowrec1 arrowrun001 arrowrun002 arrowrun003 arrowrun004"
+
+ecfToExpr :: LExpCmdFrame -> P (LHsExpr GhcPs)
+ecfToExpr (dL->L l a) =
+  case a of
+    ECFrameExp e -> return (cL l e)
+    ECFrameAmb e _ -> return (cL l e)
+    ECFrameCmd c -> do
+      addError l $ vcat
+        [ text "Arrow command found where an expression was expected:",
+          nest 2 (ppr c) ]
+      return (cL l hsHoleExpr)
+
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
+
 checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs)
 checkCommand lc = locMap checkCmd lc