Use trees that grow for rebindable operators for `<-` binds

Also add more documentation.

1 files changed, 43 insertions, 28 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 3152571508..43cc74563a 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1828,16 +1828,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
             -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | BindStmt (XBindStmt idL idR body) -- Post typechecking,
-                                -- result type of the function passed to bind;
-                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
+  | BindStmt (XBindStmt idL idR body)
+             -- ^ Post renaming has optional fail and bind / (>>=) operator.
+             -- Post typechecking, also has result type of the
+             -- function passed to bind; that is, S in (>>=)
+             -- :: Q -> (R -> S) -> T
+             -- See Note [The type of bind in Stmts]
              (LPat idL)
              body
-             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
-             (Maybe (SyntaxExpr idR)) -- The fail operator
-             -- The fail operator is Nothing
-             -- if the pattern match can't fail
-             -- See Note [NoSyntaxExpr] (2)
 
   -- | 'ApplicativeStmt' represents an applicative expression built with
   -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
@@ -1950,8 +1948,8 @@ data RecStmtTc =
 type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField
 
 type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcRn b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcTc b = Type
+type instance XBindStmt        (GhcPass _) GhcRn b = (SyntaxExpr GhcRn, FailOperator GhcRn)
+type instance XBindStmt        (GhcPass _) GhcTc b = (SyntaxExpr GhcTc, Type, FailOperator GhcTc)
 
 type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
 type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
@@ -1994,25 +1992,41 @@ data ParStmtBlock idL idR
 type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField
 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
 
+-- | The fail operator
+--
+-- This is used for `.. <-` "bind statments" in do notation, including
+-- non-monadic "binds" in applicative.
+--
+-- The fail operator is 'Just expr' if it potentially fail monadically. if the
+-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete
+-- pattern exception), it is 'Nothing'.
+--
+-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of
+-- expression in the 'Just' case, and why it is so.
+--
+-- See Note [Failing pattern matches in Stmts] for which contexts for
+-- '@BindStmt@'s should use the monadic fail and which shouldn't.
+type FailOperator id = Maybe (SyntaxExpr id)
+
 -- | Applicative Argument
 data ApplicativeArg idL
   = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
     { xarg_app_arg_one  :: (XApplicativeArgOne idL)
+      -- ^ The fail operator, after renaming
+      --
+      -- The fail operator is needed if this is a BindStmt
+      -- where the pattern can fail. E.g.:
+      -- (Just a) <- stmt
+      -- The fail operator will be invoked if the pattern
+      -- match fails.
+      -- It is also used for guards in MonadComprehensions.
+      -- The fail operator is Nothing
+      -- if the pattern match can't fail
     , app_arg_pattern   :: (LPat idL) -- WildPat if it was a BodyStmt (see below)
     , arg_expr          :: (LHsExpr idL)
     , is_body_stmt      :: Bool -- True <=> was a BodyStmt
                               -- False <=> was a BindStmt
                               -- See Note [Applicative BodyStmt]
-    , fail_operator     :: Maybe (SyntaxExpr idL) -- The fail operator
-                         -- The fail operator is needed if this is a BindStmt
-                         -- where the pattern can fail. E.g.:
-                         -- (Just a) <- stmt
-                         -- The fail operator will be invoked if the pattern
-                         -- match fails.
-                         -- It is also used for guards in MonadComprehensions.
-                         -- The fail operator is Nothing
-                         -- if the pattern match can't fail
-                         -- See Note [NoSyntaxExpr] (2)
     }
   | ApplicativeArgMany     -- do { stmts; return vars }
     { xarg_app_arg_many :: (XApplicativeArgMany idL)
@@ -2022,7 +2036,10 @@ data ApplicativeArg idL
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
-type instance XApplicativeArgOne  (GhcPass _) = NoExtField
+type instance XApplicativeArgOne GhcPs = NoExtField
+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
+
 type instance XApplicativeArgMany (GhcPass _) = NoExtField
 type instance XXApplicativeArg    (GhcPass _) = NoExtCon
 
@@ -2213,7 +2230,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _)
         Just False -> text "return"
         Nothing -> empty) <+>
       ppr expr
-pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
+pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr]
 pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds]
 pprStmt (BodyStmt _ expr _ _)     = ppr expr
 pprStmt (ParStmt _ stmtss _ _)   = sep (punctuate (text " | ") (map ppr stmtss))
@@ -2248,13 +2265,12 @@ pprStmt (ApplicativeStmt _ args mb_join)
    flattenStmt stmt = [ppr stmt]
 
    flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
-   flattenArg (_, ApplicativeArgOne _ pat expr isBody _)
+   flattenArg (_, ApplicativeArgOne _ pat expr isBody)
      | isBody =  -- See Note [Applicative BodyStmt]
      [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
              :: ExprStmt (GhcPass idL))]
      | otherwise =
-     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
-             :: ExprStmt (GhcPass idL))]
+     [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
    flattenArg (_, ApplicativeArgMany _ stmts _ _) =
      concatMap flattenStmt stmts
 
@@ -2274,13 +2290,12 @@ instance (OutputableBndrId idL)
   ppr = pprArg
 
 pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
-pprArg (ApplicativeArgOne _ pat expr isBody _)
+pprArg (ApplicativeArgOne _ pat expr isBody)
   | isBody =  -- See Note [Applicative BodyStmt]
     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
   | otherwise =
-    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr Nothing
-            :: ExprStmt (GhcPass idL))
+    ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
 pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>