Pattern/expression ambiguity resolution

This patch removes 'EWildPat', 'EAsPat', 'EViewPat', and 'ELazyPat'
from 'HsExpr' by using the ambiguity resolution system introduced
earlier for the command/expression ambiguity.

Problem: there are places in the grammar where we do not know whether we
are parsing an expression or a pattern, for example:

	do { Con a b <- x } -- 'Con a b' is a pattern
	do { Con a b }      -- 'Con a b' is an expression

Until we encounter binding syntax (<-) we don't know whether to parse
'Con a b' as an expression or a pattern.

The old solution was to parse as HsExpr always, and rejig later:

	checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)

This meant polluting 'HsExpr' with pattern-related constructors. In
other words, limitations of the parser were affecting the AST, and all
other code (the renamer, the typechecker) had to deal with these extra
constructors.

We fix this abstraction leak by parsing into an overloaded
representation:

	class DisambECP b where ...
	newtype ECP = ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }

See Note [Ambiguous syntactic categories] for details.

Now the intricacies of parsing have no effect on the hsSyn AST when it
comes to the expression/pattern ambiguity.

compiler/deSugar/DsExpr.hs

@@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
 
 -- HsSyn constructs that just shouldn't be here:
 ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
-ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"
-ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"
-ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"
-ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat"
 ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
 ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
 ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"

compiler/hieFile/HieAst.hs

@@ -870,18 +870,6 @@ instance ( a ~ GhcPass p
       HsSpliceE _ x ->
         [ toHie $ L mspan x
         ]
-      EWildPat _ -> []
-      EAsPat _ a b ->
-        [ toHie $ C Use a
-        , toHie b
-        ]
-      EViewPat _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      ELazyPat _ a ->
-        [ toHie a
-        ]
       XExpr _ -> []
 
 instance ( a ~ GhcPass p

compiler/hsSyn/HsExpr.hs

@@ -624,32 +624,6 @@ data HsExpr p
         -- See note [Pragma source text] in BasicTypes
      (LHsExpr p)
 
-  ---------------------------------------
-  -- These constructors only appear temporarily in the parser.
-  -- The renamer translates them into the Right Thing.
-
-  | EWildPat (XEWildPat p)        -- wildcard
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | EAsPat      (XEAsPat p)
-                (Located (IdP p)) -- as pattern
-                (LHsExpr p)
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | EViewPat    (XEViewPat p)
-                (LHsExpr p) -- view pattern
-                (LHsExpr p)
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | ELazyPat    (XELazyPat p) (LHsExpr p) -- ~ pattern
-
-
   ---------------------------------------
   -- Finally, HsWrap appears only in typechecker output
   -- The contained Expr is *NOT* itself an HsWrap.
@@ -761,10 +735,6 @@ type instance XStatic        GhcTc = NameSet
 type instance XTick          (GhcPass _) = NoExt
 type instance XBinTick       (GhcPass _) = NoExt
 type instance XTickPragma    (GhcPass _) = NoExt
-type instance XEWildPat      (GhcPass _) = NoExt
-type instance XEAsPat        (GhcPass _) = NoExt
-type instance XEViewPat      (GhcPass _) = NoExt
-type instance XELazyPat      (GhcPass _) = NoExt
 type instance XWrap          (GhcPass _) = NoExt
 type instance XXExpr         (GhcPass _) = NoExt
 
@@ -924,21 +894,12 @@ ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
 
 ppr_expr (OpApp _ e1 op e2)
-  | Just pp_op <- should_print_infix (unLoc op)
+  | Just pp_op <- ppr_infix_expr (unLoc op)
   = pp_infixly pp_op
   | otherwise
   = pp_prefixly
 
   where
-    should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
-    should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
-    should_print_infix (HsRecFld _ f)    = Just (pprInfixOcc f)
-    should_print_infix (HsUnboundVar _ h@TrueExprHole{})
-                                       = Just (pprInfixOcc (unboundVarOcc h))
-    should_print_infix (EWildPat _)    = Just (text "`_`")
-    should_print_infix (HsWrap _ _ e)  = should_print_infix e
-    should_print_infix _               = Nothing
-
     pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens
     pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear
 
@@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2)
 ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
 
 ppr_expr (SectionL _ expr op)
-  = case unLoc op of
-      HsVar _ (L _ v)  -> pp_infixly v
-      HsConLikeOut _ c -> pp_infixly (conLikeName c)
-      HsUnboundVar _ h@TrueExprHole{}
-                       -> pp_infixly (unboundVarOcc h)
-      _                -> pp_prefixly
+  | Just pp_op <- ppr_infix_expr (unLoc op)
+  = pp_infixly pp_op
+  | otherwise
+  = pp_prefixly
   where
     pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, text "x_ )"])
 
-    pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
-    pp_infixly v = (sep [pp_expr, pprInfixOcc v])
+    pp_infixly v = (sep [pp_expr, v])
 
 ppr_expr (SectionR _ op expr)
-  = case unLoc op of
-      HsVar _ (L _ v)  -> pp_infixly v
-      HsConLikeOut _ c -> pp_infixly (conLikeName c)
-      HsUnboundVar _ h@TrueExprHole{}
-                       -> pp_infixly (unboundVarOcc h)
-      _                -> pp_prefixly
+  | Just pp_op <- ppr_infix_expr (unLoc op)
+  = pp_infixly pp_op
+  | otherwise
+  = pp_prefixly
   where
     pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
                        4 (pp_expr <> rparen)
 
-    pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
-    pp_infixly v = sep [pprInfixOcc v, pp_expr]
+    pp_infixly v = sep [v, pp_expr]
 
 ppr_expr (ExplicitTuple _ exprs boxity)
   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
@@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig)
 
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
 
-ppr_expr (EWildPat _)     = char '_'
-ppr_expr (ELazyPat _ e)   = char '~' <> ppr e
-ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e
-ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
-
 ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
   = sep [ pprWithSourceText st (text "{-# SCC")
          -- no doublequotes if stl empty, for the case where the SCC was written
@@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
 ppr_expr (HsRecFld _ f) = ppr f
 ppr_expr (XExpr x) = ppr x
 
+ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc
+ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
+ppr_infix_expr (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
+ppr_infix_expr (HsRecFld _ f)    = Just (pprInfixOcc f)
+ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h))
+ppr_infix_expr (HsWrap _ _ e)    = ppr_infix_expr e
+ppr_infix_expr _                 = Nothing
+
 ppr_apps :: (OutputableBndrId (GhcPass p))
          => HsExpr (GhcPass p)
          -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
@@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go
     go (RecordUpd{})                  = False
     go (ExprWithTySig{})              = p >= sigPrec
     go (ArithSeq{})                   = False
-    go (EWildPat{})                   = False
-    go (ELazyPat{})                   = False
-    go (EAsPat{})                     = False
-    go (EViewPat{})                   = True
     go (HsSCC{})                      = p >= appPrec
     go (HsWrap _ _ e)                 = go e
     go (HsSpliceE{})                  = False

compiler/hsSyn/HsExtension.hs

@@ -539,10 +539,6 @@ type family XStatic         x
 type family XTick           x
 type family XBinTick        x
 type family XTickPragma     x
-type family XEWildPat       x
-type family XEAsPat         x
-type family XEViewPat       x
-type family XELazyPat       x
 type family XWrap           x
 type family XXExpr          x
 
@@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) =
        , c (XTick           x)
        , c (XBinTick        x)
        , c (XTickPragma     x)
-       , c (XEWildPat       x)
-       , c (XEAsPat         x)
-       , c (XEViewPat       x)
-       , c (XELazyPat       x)
        , c (XWrap           x)
        , c (XXExpr          x)
        )

compiler/parser/Lexer.x

@@ -58,7 +58,6 @@ module Lexer (
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..),
-   addWarning,
    lexTokenStream,
    AddAnn,mkParensApiAnn,
    commentToAnnotation
@@ -2493,6 +2492,9 @@ class Monad m => MonadP m where
   --   more than one parse error per file.
   --
   addError :: SrcSpan -> SDoc -> m ()
+  -- | Add a warning to the accumulator.
+  --   Use 'getMessages' to get the accumulated warnings.
+  addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()
   -- | Add a fatal error. This will be the last error reported by the parser, and
   --   the parser will not produce any result, ending in a 'PFailed' state.
   addFatalError :: SrcSpan -> SDoc -> m a
@@ -2515,6 +2517,16 @@ instance MonadP P where
                      es' = es `snocBag` errormsg
                  in (ws, es')
          in POk s{messages=m'} ()
+  addWarning option srcspan warning
+   = P $ \s@PState{messages=m, options=o} ->
+         let
+             m' d =
+                 let (ws, es) = m d
+                     warning' = makeIntoWarning (Reason option) $
+                        mkWarnMsg d srcspan alwaysQualify warning
+                     ws' = if warnopt option o then ws `snocBag` warning' else ws
+                 in (ws', es)
+         in POk s{messages=m'} ()
   addFatalError span msg =
     addError span msg >> P PFailed
   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
@@ -2524,20 +2536,6 @@ instance MonadP P where
     addAnnotationOnly l a v
     allocateComments l
 
--- | Add a warning to the accumulator.
---   Use 'getMessages' to get the accumulated warnings.
-addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
-addWarning option srcspan warning
- = P $ \s@PState{messages=m, options=o} ->
-       let
-           m' d =
-               let (ws, es) = m d
-                   warning' = makeIntoWarning (Reason option) $
-                      mkWarnMsg d srcspan alwaysQualify warning
-                   ws' = if warnopt option o then ws `snocBag` warning' else ws
-               in (ws', es)
-       in POk s{messages=m'} ()
-
 addTabWarning :: RealSrcSpan -> P ()
 addTabWarning srcspan
  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->