never executed always true always false
    1 
    2 {-# LANGUAGE ConstraintKinds     #-}
    3 {-# LANGUAGE CPP                 #-}
    4 {-# LANGUAGE FlexibleContexts    #-}
    5 {-# LANGUAGE MultiWayIf          #-}
    6 {-# LANGUAGE ScopedTypeVariables #-}
    7 {-# LANGUAGE TypeApplications    #-}
    8 {-# LANGUAGE TypeFamilies        #-}
    9 
   10 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
   11 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
   12 
   13 {-
   14 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   15 
   16 Renaming of expressions
   17 
   18 Basically dependency analysis.
   19 
   20 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
   21 general, all of these functions return a renamed thing, and a set of
   22 free variables.
   23 -}
   24 
   25 module GHC.Rename.Expr (
   26         rnLExpr, rnExpr, rnStmts,
   27         AnnoBody
   28    ) where
   29 
   30 import GHC.Prelude
   31 
   32 import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
   33                         , rnMatchGroup, rnGRHS, makeMiniFixityEnv)
   34 import GHC.Hs
   35 import GHC.Tc.Errors.Types
   36 import GHC.Tc.Utils.Env ( isBrackStage )
   37 import GHC.Tc.Utils.Monad
   38 import GHC.Unit.Module ( getModule, isInteractiveModule )
   39 import GHC.Rename.Env
   40 import GHC.Rename.Fixity
   41 import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
   42                         , bindLocalNames
   43                         , mapMaybeFvRn, mapFvRn
   44                         , warnUnusedLocalBinds, typeAppErr
   45                         , checkUnusedRecordWildcard
   46                         , wrapGenSpan, genHsIntegralLit, genHsTyLit
   47                         , genHsVar, genLHsVar, genHsApp, genHsApps
   48                         , genAppType )
   49 import GHC.Rename.Unbound ( reportUnboundName )
   50 import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )
   51 import GHC.Rename.HsType
   52 import GHC.Rename.Pat
   53 import GHC.Driver.Session
   54 import GHC.Builtin.Names
   55 
   56 import GHC.Types.FieldLabel
   57 import GHC.Types.Fixity
   58 import GHC.Types.Hint (suggestExtension)
   59 import GHC.Types.Id.Make
   60 import GHC.Types.Name
   61 import GHC.Types.Name.Set
   62 import GHC.Types.Name.Reader
   63 import GHC.Types.Unique.Set
   64 import GHC.Types.SourceText
   65 import GHC.Utils.Misc
   66 import GHC.Data.List.SetOps ( removeDups )
   67 import GHC.Utils.Error
   68 import GHC.Utils.Panic
   69 import GHC.Utils.Panic.Plain
   70 import GHC.Utils.Outputable as Outputable
   71 import GHC.Types.SrcLoc
   72 import Control.Monad
   73 import GHC.Builtin.Types ( nilDataConName )
   74 import qualified GHC.LanguageExtensions as LangExt
   75 
   76 import Data.List (unzip4, minimumBy)
   77 import Data.Maybe (isJust, isNothing)
   78 import Control.Arrow (first)
   79 import Data.Ord
   80 import Data.Array
   81 import qualified Data.List.NonEmpty as NE
   82 
   83 {- Note [Handling overloaded and rebindable constructs]
   84 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   85 For overloaded constructs (overloaded literals, lists, strings), and
   86 rebindable constructs (e.g. if-then-else), our general plan is this,
   87 using overloaded labels #foo as an example:
   88 
   89 * In the RENAMER: transform
   90       HsOverLabel "foo"
   91       ==> XExpr (HsExpansion (HsOverLabel #foo)
   92                              (fromLabel `HsAppType` "foo"))
   93   We write this more compactly in concrete-syntax form like this
   94       #foo  ==>  fromLabel @"foo"
   95 
   96   Recall that in (HsExpansion orig expanded), 'orig' is the original term
   97   the user wrote, and 'expanded' is the expanded or desugared version
   98   to be typechecked.
   99 
  100 * In the TYPECHECKER: typecheck the expansion, in this case
  101       fromLabel @"foo"
  102   The typechecker (and desugarer) will never see HsOverLabel
  103 
  104 In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr
  105 Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion.
  106 
  107 RebindableSyntax:
  108   If RebindableSyntax is off we use the built-in 'fromLabel', defined in
  109      GHC.Builtin.Names.fromLabelClassOpName
  110   If RebindableSyntax if ON, we look up "fromLabel" in the environment
  111      to get whichever one is in scope.
  112 This is accomplished by lookupSyntaxName, and it applies to all the
  113 constructs below.
  114 
  115 See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat
  116 for the story with patterns.
  117 
  118 Here are the expressions that we transform in this way. Some are uniform,
  119 but several have a little bit of special treatment:
  120 
  121 * HsIf (if-the-else)
  122      if b then e1 else e2  ==>  ifThenElse b e1 e2
  123   We do this /only/ if rebindable syntax is on, because the coverage
  124   checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr)
  125   That means the typechecker and desugarer need to understand HsIf
  126   for the non-rebindable-syntax case.
  127 
  128 * OverLabel (overloaded labels, #lbl)
  129      #lbl  ==>  fromLabel @"lbl"
  130   As ever, we use lookupSyntaxName to look up 'fromLabel'
  131   See Note [Overloaded labels]
  132 
  133 * ExplicitList (explicit lists [a,b,c])
  134   When (and only when) OverloadedLists is on
  135      [e1,e2]  ==>  fromListN 2 [e1,e2]
  136   NB: the type checker and desugarer still see ExplicitList,
  137       but to them it always means the built-in lists.
  138 
  139 * SectionL and SectionR (left and right sections)
  140      (`op` e) ==> rightSection op e
  141      (e `op`) ==> leftSection  (op e)
  142   where `leftSection` and `rightSection` are representation-polymorphic
  143   wired-in Ids. See Note [Left and right sections]
  144 
  145 * It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`
  146   form, because the renamer does precedence rearrangement after name
  147   resolution.  So the renamer leaves an OpApp as an OpApp.
  148 
  149   The typechecker turns `OpApp` into a use of `HsExpansion`
  150   on the fly, in GHC.Tc.Gen.Head.splitHsApps.  RebindableSyntax
  151   does not affect this.
  152 
  153 Note [Overloaded labels]
  154 ~~~~~~~~~~~~~~~~~~~~~~~~
  155 For overloaded labels, note that we /only/ apply `fromLabel` to the
  156 Symbol argument, so the resulting expression has type
  157     fromLabel @"foo" :: forall a. IsLabel "foo" a => a
  158 Now ordinary Visible Type Application can be used to instantiate the 'a':
  159 the user may have written (#foo @Int).
  160 
  161 Notice that this all works fine in a kind-polymorphic setting (#19154).
  162 Suppose we have
  163     fromLabel :: forall {k1} {k2} (a:k1). blah
  164 
  165 Then we want to instantiate those inferred quantifiers k1,k2, before
  166 type-applying to "foo", so we get
  167     fromLabel @Symbol @blah @"foo" ...
  168 
  169 And those inferred kind quantifiers will indeed be instantiated when we
  170 typecheck the renamed-syntax call (fromLabel @"foo").
  171 -}
  172 
  173 {-
  174 ************************************************************************
  175 *                                                                      *
  176 \subsubsection{Expressions}
  177 *                                                                      *
  178 ************************************************************************
  179 -}
  180 
  181 rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
  182 rnExprs ls = rnExprs' ls emptyUniqSet
  183  where
  184   rnExprs' [] acc = return ([], acc)
  185   rnExprs' (expr:exprs) acc =
  186    do { (expr', fvExpr) <- rnLExpr expr
  187         -- Now we do a "seq" on the free vars because typically it's small
  188         -- or empty, especially in very long lists of constants
  189       ; let  acc' = acc `plusFV` fvExpr
  190       ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
  191       ; return (expr':exprs', fvExprs) }
  192 
  193 -- Variables. We look up the variable and return the resulting name.
  194 
  195 rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
  196 rnLExpr = wrapLocFstMA rnExpr
  197 
  198 rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
  199 
  200 finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
  201 -- Separated from rnExpr because it's also used
  202 -- when renaming infix expressions
  203 finishHsVar (L l name)
  204  = do { this_mod <- getModule
  205       ; when (nameIsLocalOrFrom this_mod name) $
  206         checkThLocalName name
  207       ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
  208 
  209 rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
  210 rnUnboundVar v =
  211   if isUnqual v
  212   then -- Treat this as a "hole"
  213        -- Do not fail right now; instead, return HsUnboundVar
  214        -- and let the type checker report the error
  215        return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)
  216 
  217         else -- Fail immediately (qualified name)
  218              do { n <- reportUnboundName v
  219                 ; return (HsVar noExtField (noLocA n), emptyFVs) }
  220 
  221 rnExpr (HsVar _ (L l v))
  222   = do { dflags <- getDynFlags
  223        ; mb_name <- lookupExprOccRn v
  224 
  225        ; case mb_name of {
  226            Nothing -> rnUnboundVar v ;
  227            Just (NormalGreName name)
  228               | name == nilDataConName -- Treat [] as an ExplicitList, so that
  229                                        -- OverloadedLists works correctly
  230                                        -- Note [Empty lists] in GHC.Hs.Expr
  231               , xopt LangExt.OverloadedLists dflags
  232               -> rnExpr (ExplicitList noAnn [])
  233 
  234               | otherwise
  235               -> finishHsVar (L (na2la l) name) ;
  236             Just (FieldGreName fl)
  237               -> do { let sel_name = flSelector fl
  238                     ; this_mod <- getModule
  239                     ; when (nameIsLocalOrFrom this_mod sel_name) $
  240                         checkThLocalName sel_name
  241                     ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
  242                     }
  243          }
  244        }
  245 
  246 rnExpr (HsIPVar x v)
  247   = return (HsIPVar x v, emptyFVs)
  248 
  249 rnExpr (HsUnboundVar _ v)
  250   = return (HsUnboundVar noExtField v, emptyFVs)
  251 
  252 -- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
  253 rnExpr (HsOverLabel _ v)
  254   = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
  255        ; return ( mkExpandedExpr (HsOverLabel noAnn v) $
  256                   HsAppType noExtField (genLHsVar from_label) hs_ty_arg
  257                 , fvs ) }
  258   where
  259     hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
  260                 HsTyLit noExtField (HsStrTy NoSourceText v)
  261 
  262 rnExpr (HsLit x lit@(HsString src s))
  263   = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
  264        ; if opt_OverloadedStrings then
  265             rnExpr (HsOverLit x (mkHsIsString src s))
  266          else do {
  267             ; rnLit lit
  268             ; return (HsLit x (convertLit lit), emptyFVs) } }
  269 
  270 rnExpr (HsLit x lit)
  271   = do { rnLit lit
  272        ; return (HsLit x(convertLit lit), emptyFVs) }
  273 
  274 rnExpr (HsOverLit x lit)
  275   = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
  276        ; case mb_neg of
  277               Nothing -> return (HsOverLit x lit', fvs)
  278               Just neg ->
  279                  return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit'))
  280                         , fvs ) }
  281 
  282 rnExpr (HsApp x fun arg)
  283   = do { (fun',fvFun) <- rnLExpr fun
  284        ; (arg',fvArg) <- rnLExpr arg
  285        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
  286 
  287 rnExpr (HsAppType _ fun arg)
  288   = do { type_app <- xoptM LangExt.TypeApplications
  289        ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
  290        ; (fun',fvFun) <- rnLExpr fun
  291        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
  292        ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) }
  293 
  294 rnExpr (OpApp _ e1 op e2)
  295   = do  { (e1', fv_e1) <- rnLExpr e1
  296         ; (e2', fv_e2) <- rnLExpr e2
  297         ; (op', fv_op) <- rnLExpr op
  298 
  299         -- Deal with fixity
  300         -- When renaming code synthesised from "deriving" declarations
  301         -- we used to avoid fixity stuff, but we can't easily tell any
  302         -- more, so I've removed the test.  Adding HsPars in GHC.Tc.Deriv.Generate
  303         -- should prevent bad things happening.
  304         ; fixity <- case op' of
  305               L _ (HsVar _ (L _ n)) -> lookupFixityRn n
  306               L _ (HsRecSel _ f)    -> lookupFieldFixityRn f
  307               _ -> return (Fixity NoSourceText minPrecedence InfixL)
  308                    -- c.f. lookupFixity for unbound
  309 
  310         ; lexical_negation <- xoptM LangExt.LexicalNegation
  311         ; let negation_handling | lexical_negation = KeepNegationIntact
  312                                 | otherwise = ReassociateNegation
  313         ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
  314         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
  315 
  316 rnExpr (NegApp _ e _)
  317   = do { (e', fv_e)         <- rnLExpr e
  318        ; (neg_name, fv_neg) <- lookupSyntax negateName
  319        ; final_e            <- mkNegAppRn e' neg_name
  320        ; return (final_e, fv_e `plusFV` fv_neg) }
  321 
  322 ------------------------------------------
  323 -- Record dot syntax
  324 
  325 rnExpr (HsGetField _ e f)
  326  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
  327       ; (e, fv_e) <- rnLExpr e
  328       ; let f' = rnDotFieldOcc f
  329       ; return ( mkExpandedExpr
  330                    (HsGetField noExtField e f')
  331                    (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
  332                , fv_e `plusFV` fv_getField ) }
  333 
  334 rnExpr (HsProjection _ fs)
  335   = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
  336        ; circ <- lookupOccRn compose_RDR
  337        ; let fs' = fmap rnDotFieldOcc fs
  338        ; return ( mkExpandedExpr
  339                     (HsProjection noExtField fs')
  340                     (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))
  341                 , unitFV circ `plusFV` fv_getField) }
  342 
  343 ------------------------------------------
  344 -- Template Haskell extensions
  345 rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
  346 
  347 rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
  348 
  349 ---------------------------------------------
  350 --      Sections
  351 -- See Note [Parsing sections] in GHC.Parser
  352 rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)
  353   = do  { (section', fvs) <- rnSection section
  354         ; return (HsPar x lpar (L loc section') rpar, fvs) }
  355 
  356 rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)
  357   = do  { (section', fvs) <- rnSection section
  358         ; return (HsPar x lpar (L loc section') rpar, fvs) }
  359 
  360 rnExpr (HsPar x lpar e rpar)
  361   = do  { (e', fvs_e) <- rnLExpr e
  362         ; return (HsPar x lpar e' rpar, fvs_e) }
  363 
  364 rnExpr expr@(SectionL {})
  365   = do  { addErr (sectionErr expr); rnSection expr }
  366 rnExpr expr@(SectionR {})
  367   = do  { addErr (sectionErr expr); rnSection expr }
  368 
  369 ---------------------------------------------
  370 rnExpr (HsPragE x prag expr)
  371   = do { (expr', fvs_expr) <- rnLExpr expr
  372        ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
  373   where
  374     rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
  375     rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
  376 
  377 rnExpr (HsLam x matches)
  378   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
  379        ; return (HsLam x matches', fvMatch) }
  380 
  381 rnExpr (HsLamCase x matches)
  382   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
  383        ; return (HsLamCase x matches', fvs_ms) }
  384 
  385 rnExpr (HsCase _ expr matches)
  386   = do { (new_expr, e_fvs) <- rnLExpr expr
  387        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
  388        ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) }
  389 
  390 rnExpr (HsLet _ tkLet binds tkIn expr)
  391   = rnLocalBindsAndThen binds $ \binds' _ -> do
  392       { (expr',fvExpr) <- rnLExpr expr
  393       ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }
  394 
  395 rnExpr (HsDo _ do_or_lc (L l stmts))
  396  = do { ((stmts1, _), fvs1) <-
  397           rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
  398             (\ _ -> return ((), emptyFVs))
  399       ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
  400       ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
  401 
  402 -- ExplicitList: see Note [Handling overloaded and rebindable constructs]
  403 rnExpr (ExplicitList _ exps)
  404   = do  { (exps', fvs) <- rnExprs exps
  405         ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
  406         ; if not opt_OverloadedLists
  407           then return  (ExplicitList noExtField exps', fvs)
  408           else
  409     do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
  410        ; let rn_list  = ExplicitList noExtField exps'
  411              lit_n    = mkIntegralLit (length exps)
  412              hs_lit   = genHsIntegralLit lit_n
  413              exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
  414        ; return ( mkExpandedExpr rn_list exp_list
  415                 , fvs `plusFV` fvs') } }
  416 
  417 rnExpr (ExplicitTuple _ tup_args boxity)
  418   = do { checkTupleSection tup_args
  419        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
  420        ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }
  421   where
  422     rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e
  423                                 ; return (Present x e', fvs) }
  424     rnTupArg (Missing _) = return (Missing noExtField, emptyFVs)
  425 
  426 rnExpr (ExplicitSum _ alt arity expr)
  427   = do { (expr', fvs) <- rnLExpr expr
  428        ; return (ExplicitSum noExtField alt arity expr', fvs) }
  429 
  430 rnExpr (RecordCon { rcon_con = con_id
  431                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
  432   = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
  433        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
  434        ; (flds', fvss) <- mapAndUnzipM rn_field flds
  435        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
  436        ; return (RecordCon { rcon_ext = noExtField
  437                            , rcon_con = con_lname, rcon_flds = rec_binds' }
  438                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
  439   where
  440     mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)
  441     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)
  442                             ; return (L l (fld { hfbRHS = arg' }), fvs) }
  443 
  444 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
  445   = case rbinds of
  446       Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update.
  447         do  { ; (e, fv_e) <- rnLExpr expr
  448               ; (rs, fv_rs) <- rnHsRecUpdFields flds
  449               ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs )
  450             }
  451       Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.
  452         do { ; unlessXOptM LangExt.RebindableSyntax $
  453                  addErr $ TcRnUnknownMessage $ mkPlainError noHints $
  454                    text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."
  455              ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]
  456              ; punsEnabled <-xoptM LangExt.NamedFieldPuns
  457              ; unless (null punnedFields || punsEnabled) $
  458                  addErr $ TcRnUnknownMessage $ mkPlainError noHints $
  459                    text "For this to work enable NamedFieldPuns."
  460              ; (getField, fv_getField) <- lookupSyntaxName getFieldName
  461              ; (setField, fv_setField) <- lookupSyntaxName setFieldName
  462              ; (e, fv_e) <- rnLExpr expr
  463              ; (us, fv_us) <- rnHsUpdProjs flds
  464              ; return ( mkExpandedExpr
  465                           (RecordUpd noExtField e (Right us))
  466                           (mkRecordDotUpd getField setField e us)
  467                          , plusFVs [fv_getField, fv_setField, fv_e, fv_us] )
  468              }
  469 
  470 rnExpr (ExprWithTySig _ expr pty)
  471   = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
  472         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
  473                              rnLExpr expr
  474         ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
  475 
  476 -- HsIf: see Note [Handling overloaded and rebindable constructs]
  477 -- Because of the coverage checker it is most convenient /not/ to
  478 -- expand HsIf; unless we are in rebindable syntax.
  479 rnExpr (HsIf _ p b1 b2)
  480   = do { (p',  fvP)  <- rnLExpr p
  481        ; (b1', fvB1) <- rnLExpr b1
  482        ; (b2', fvB2) <- rnLExpr b2
  483        ; let fvs_if = plusFVs [fvP, fvB1, fvB2]
  484              rn_if  = HsIf noExtField  p' b1' b2'
  485 
  486        -- Deal with rebindable syntax
  487        -- See Note [Handling overloaded and rebindable constructs]
  488        ; mb_ite <- lookupIfThenElse
  489        ; case mb_ite of
  490             Nothing  -- Non rebindable-syntax case
  491               -> return (rn_if, fvs_if)
  492 
  493             Just ite_name   -- Rebindable-syntax case
  494               -> do { let ds_if = genHsApps ite_name [p', b1', b2']
  495                           fvs   = plusFVs [fvs_if, unitFV ite_name]
  496                     ; return (mkExpandedExpr rn_if ds_if, fvs) } }
  497 
  498 rnExpr (HsMultiIf _ alts)
  499   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
  500        ; return (HsMultiIf noExtField alts', fvs) }
  501 
  502 rnExpr (ArithSeq _ _ seq)
  503   = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
  504        ; (new_seq, fvs) <- rnArithSeq seq
  505        ; if opt_OverloadedLists
  506            then do {
  507             ; (from_list_name, fvs') <- lookupSyntax fromListName
  508             ; return (ArithSeq noExtField (Just from_list_name) new_seq
  509                      , fvs `plusFV` fvs') }
  510            else
  511             return (ArithSeq noExtField Nothing new_seq, fvs) }
  512 
  513 {-
  514 ************************************************************************
  515 *                                                                      *
  516         Static values
  517 *                                                                      *
  518 ************************************************************************
  519 
  520 For the static form we check that it is not used in splices.
  521 We also collect the free variables of the term which come from
  522 this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
  523 -}
  524 
  525 rnExpr e@(HsStatic _ expr) = do
  526     -- Normally, you wouldn't be able to construct a static expression without
  527     -- first enabling -XStaticPointers in the first place, since that extension
  528     -- is what makes the parser treat `static` as a keyword. But this is not a
  529     -- sufficient safeguard, as one can construct static expressions by another
  530     -- mechanism: Template Haskell (see #14204). To ensure that GHC is
  531     -- absolutely prepared to cope with static forms, we check for
  532     -- -XStaticPointers here as well.
  533     unlessXOptM LangExt.StaticPointers $
  534       addErr $ TcRnUnknownMessage $ mkPlainError noHints $
  535         hang (text "Illegal static expression:" <+> ppr e)
  536                   2 (text "Use StaticPointers to enable this extension")
  537     (expr',fvExpr) <- rnLExpr expr
  538     stage <- getStage
  539     case stage of
  540       Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep
  541              [ text "static forms cannot be used in splices:"
  542              , nest 2 $ ppr e
  543              ]
  544       _ -> return ()
  545     mod <- getModule
  546     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
  547     return (HsStatic fvExpr' expr', fvExpr)
  548 
  549 {- *********************************************************************
  550 *                                                                      *
  551         Arrow notation
  552 *                                                                      *
  553 ********************************************************************* -}
  554 
  555 rnExpr (HsProc x pat body)
  556   = newArrowScope $
  557     rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do
  558       { (body',fvBody) <- rnCmdTop body
  559       ; return (HsProc x pat' body', fvBody) }
  560 
  561 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
  562         -- HsWrap
  563 
  564 {- *********************************************************************
  565 *                                                                      *
  566         Operator sections
  567 *                                                                      *
  568 ********************************************************************* -}
  569 
  570 
  571 rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
  572 -- See Note [Parsing sections] in GHC.Parser
  573 -- Also see Note [Handling overloaded and rebindable constructs]
  574 
  575 rnSection section@(SectionR x op expr)
  576   -- See Note [Left and right sections]
  577   = do  { (op', fvs_op)     <- rnLExpr op
  578         ; (expr', fvs_expr) <- rnLExpr expr
  579         ; checkSectionPrec InfixR section op' expr'
  580         ; let rn_section = SectionR x op' expr'
  581               ds_section = genHsApps rightSectionName [op',expr']
  582         ; return ( mkExpandedExpr rn_section ds_section
  583                  , fvs_op `plusFV` fvs_expr) }
  584 
  585 rnSection section@(SectionL x expr op)
  586   -- See Note [Left and right sections]
  587   = do  { (expr', fvs_expr) <- rnLExpr expr
  588         ; (op', fvs_op)     <- rnLExpr op
  589         ; checkSectionPrec InfixL section op' expr'
  590         ; postfix_ops <- xoptM LangExt.PostfixOperators
  591                         -- Note [Left and right sections]
  592         ; let rn_section = SectionL x expr' op'
  593               ds_section
  594                 | postfix_ops = HsApp noAnn op' expr'
  595                 | otherwise   = genHsApps leftSectionName
  596                                    [wrapGenSpan $ HsApp noAnn op' expr']
  597         ; return ( mkExpandedExpr rn_section ds_section
  598                  , fvs_op `plusFV` fvs_expr) }
  599 
  600 rnSection other = pprPanic "rnSection" (ppr other)
  601 
  602 {- Note [Left and right sections]
  603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  604 Dealing with left sections (x *) and right sections (* x) is
  605 surprisingly fiddly.  We expand like this
  606      (`op` e) ==> rightSection op e
  607      (e `op`) ==> leftSection  (op e)
  608 
  609 Using an auxiliary function in this way avoids the awkwardness of
  610 generating a lambda, esp if `e` is a redex, so we *don't* want
  611 to generate `(\x -> op x e)`. See Historical
  612 Note [Desugaring operator sections]
  613 
  614 Here are their definitions:
  615    leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).
  616                   (a %n-> b) -> a %n-> b
  617    leftSection f x = f x
  618 
  619    rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).
  620                    (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
  621    rightSection f y x = f x y
  622 
  623 Note the wrinkles:
  624 
  625 * We do /not/ use lookupSyntaxName, which would make left and right
  626   section fall under RebindableSyntax.  Reason: it would be a user-
  627   facing change, and there are some tricky design choices (#19354).
  628   Plus, infix operator applications would be trickier to make
  629   rebindable, so it'd be inconsistent to do so for sections.
  630 
  631   TL;DR: we still us the renamer-expansion mechanism for operator
  632   sections , but only to eliminate special-purpose code paths in the
  633   renamer and desugarer.
  634 
  635 * leftSection and rightSection must be representation-polymorphic, to allow
  636   (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.
  637   Note [Wired-in Ids for rebindable syntax] in
  638 
  639 * leftSection and rightSection must be multiplicity-polymorphic.
  640   (Test linear/should_compile/OldList showed this up.)
  641 
  642 * Because they are representation-polymorphic, we have to define them
  643   as wired-in Ids, with compulsory inlining.  See
  644   GHC.Types.Id.Make.leftSectionId, rightSectionId.
  645 
  646 * leftSection is just ($) really; but unlike ($) it is
  647   representation-polymorphic in the result type, so we can write
  648   `(x +#)`, say.
  649 
  650 * The type of leftSection must have an arrow in its first argument,
  651   because (x `ord`) should be rejected, because ord does not take two
  652   arguments
  653 
  654 * It's important that we define leftSection in an eta-expanded way,
  655   (i.e. not leftSection f = f), so that
  656       (True `undefined`) `seq` ()
  657       = (leftSection (undefined True) `seq` ())
  658   evaluates to () and not undefined
  659 
  660 * If PostfixOperators is ON, then we expand a left section like this:
  661       (e `op`)  ==>   op e
  662   with no auxiliary function at all.  Simple!
  663 
  664 
  665 Historical Note [Desugaring operator sections]
  666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  667 This Note explains some historical trickiness in desugaring left and
  668 right sections.  That trickiness has completely disappeared now that
  669 we desugar to calls to 'leftSection` and `rightSection`, but I'm
  670 leaving it here to remind us how nice the new story is.
  671 
  672 Desugaring left sections with -XPostfixOperators is straightforward: convert
  673 (expr `op`) to (op expr).
  674 
  675 Without -XPostfixOperators it's a bit more tricky. At first it looks as if we
  676 can convert
  677 
  678     (expr `op`)
  679 
  680 naively to
  681 
  682     \x -> op expr x
  683 
  684 But no!  expr might be a redex, and we can lose laziness badly this
  685 way.  Consider
  686 
  687     map (expr `op`) xs
  688 
  689 for example. If expr were a redex then eta-expanding naively would
  690 result in multiple evaluations where the user might only have expected one.
  691 
  692 So we convert instead to
  693 
  694     let y = expr in \x -> op y x
  695 
  696 Also, note that we must do this for both right and (perhaps surprisingly) left
  697 sections. Why are left sections necessary? Consider the program (found in #18151),
  698 
  699     seq (True `undefined`) ()
  700 
  701 according to the Haskell Report this should reduce to () (as it specifies
  702 desugaring via eta expansion). However, if we fail to eta expand we will rather
  703 bottom. Consequently, we must eta expand even in the case of a left section.
  704 
  705 If `expr` is actually just a variable, say, then the simplifier
  706 will inline `y`, eliminating the redundant `let`.
  707 
  708 Note that this works even in the case that `expr` is unlifted. In this case
  709 bindNonRec will automatically do the right thing, giving us:
  710 
  711     case expr of y -> (\x -> op y x)
  712 
  713 See #18151.
  714 -}
  715 
  716 {-
  717 ************************************************************************
  718 *                                                                      *
  719         Field Labels
  720 *                                                                      *
  721 ************************************************************************
  722 -}
  723 
  724 rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
  725 rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
  726 
  727 rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
  728 rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
  729 
  730 {-
  731 ************************************************************************
  732 *                                                                      *
  733         Arrow commands
  734 *                                                                      *
  735 ************************************************************************
  736 -}
  737 
  738 rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
  739 rnCmdArgs [] = return ([], emptyFVs)
  740 rnCmdArgs (arg:args)
  741   = do { (arg',fvArg) <- rnCmdTop arg
  742        ; (args',fvArgs) <- rnCmdArgs args
  743        ; return (arg':args', fvArg `plusFV` fvArgs) }
  744 
  745 rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
  746 rnCmdTop = wrapLocFstMA rnCmdTop'
  747  where
  748   rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
  749   rnCmdTop' (HsCmdTop _ cmd)
  750    = do { (cmd', fvCmd) <- rnLCmd cmd
  751         ; let cmd_names = [arrAName, composeAName, firstAName] ++
  752                           nameSetElemsStable (methodNamesCmd (unLoc cmd'))
  753         -- Generate the rebindable syntax for the monad
  754         ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
  755 
  756         ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
  757                   fvCmd `plusFV` cmd_fvs) }
  758 
  759 rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
  760 rnLCmd = wrapLocFstMA rnCmd
  761 
  762 rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
  763 
  764 rnCmd (HsCmdArrApp _ arrow arg ho rtl)
  765   = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
  766        ; (arg',fvArg) <- rnLExpr arg
  767        ; return (HsCmdArrApp noExtField arrow' arg' ho rtl,
  768                  fvArrow `plusFV` fvArg) }
  769   where
  770     select_arrow_scope tc = case ho of
  771         HsHigherOrderApp -> tc
  772         HsFirstOrderApp  -> escapeArrowScope tc
  773         -- See Note [Escaping the arrow scope] in GHC.Tc.Types
  774         -- Before renaming 'arrow', use the environment of the enclosing
  775         -- proc for the (-<) case.
  776         -- Local bindings, inside the enclosing proc, are not in scope
  777         -- inside 'arrow'.  In the higher-order case (-<<), they are.
  778 
  779 -- infix form
  780 rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
  781   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
  782        ; let L _ (HsVar _ (L _ op_name)) = op'
  783        ; (arg1',fv_arg1) <- rnCmdTop arg1
  784        ; (arg2',fv_arg2) <- rnCmdTop arg2
  785         -- Deal with fixity
  786        ; fixity <- lookupFixityRn op_name
  787        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
  788        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
  789 
  790 rnCmd (HsCmdArrForm _ op f fixity cmds)
  791   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
  792        ; (cmds',fvCmds) <- rnCmdArgs cmds
  793        ; return ( HsCmdArrForm noExtField op' f fixity cmds'
  794                 , fvOp `plusFV` fvCmds) }
  795 
  796 rnCmd (HsCmdApp x fun arg)
  797   = do { (fun',fvFun) <- rnLCmd  fun
  798        ; (arg',fvArg) <- rnLExpr arg
  799        ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
  800 
  801 rnCmd (HsCmdLam _ matches)
  802   = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches
  803        ; return (HsCmdLam noExtField matches', fvMatch) }
  804 
  805 rnCmd (HsCmdPar x lpar e rpar)
  806   = do  { (e', fvs_e) <- rnLCmd e
  807         ; return (HsCmdPar x lpar e' rpar, fvs_e) }
  808 
  809 rnCmd (HsCmdCase _ expr matches)
  810   = do { (new_expr, e_fvs) <- rnLExpr expr
  811        ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
  812        ; return (HsCmdCase noExtField new_expr new_matches
  813                 , e_fvs `plusFV` ms_fvs) }
  814 
  815 rnCmd (HsCmdLamCase x matches)
  816   = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
  817        ; return (HsCmdLamCase x new_matches, ms_fvs) }
  818 
  819 rnCmd (HsCmdIf _ _ p b1 b2)
  820   = do { (p', fvP) <- rnLExpr p
  821        ; (b1', fvB1) <- rnLCmd b1
  822        ; (b2', fvB2) <- rnLCmd b2
  823 
  824        ; mb_ite <- lookupIfThenElse
  825        ; let (ite, fvITE) = case mb_ite of
  826                 Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)
  827                 Nothing       -> (NoSyntaxExprRn,          emptyFVs)
  828 
  829        ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
  830 
  831 rnCmd (HsCmdLet _ tkLet binds tkIn cmd)
  832   = rnLocalBindsAndThen binds $ \ binds' _ -> do
  833       { (cmd',fvExpr) <- rnLCmd cmd
  834       ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }
  835 
  836 rnCmd (HsCmdDo _ (L l stmts))
  837   = do  { ((stmts', _), fvs) <-
  838             rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs))
  839         ; return ( HsCmdDo noExtField (L l stmts'), fvs ) }
  840 
  841 ---------------------------------------------------
  842 type CmdNeeds = FreeVars        -- Only inhabitants are
  843                                 --      appAName, choiceAName, loopAName
  844 
  845 -- find what methods the Cmd needs (loop, choice, apply)
  846 methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
  847 methodNamesLCmd = methodNamesCmd . unLoc
  848 
  849 methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
  850 
  851 methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
  852   = emptyFVs
  853 methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
  854   = unitFV appAName
  855 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
  856 
  857 methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c
  858 
  859 methodNamesCmd (HsCmdIf _ _ _ c1 c2)
  860   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
  861 
  862 methodNamesCmd (HsCmdLet _ _ _ _ c)      = methodNamesLCmd c
  863 methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
  864 methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c
  865 methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match
  866 
  867 methodNamesCmd (HsCmdCase _ _ matches)
  868   = methodNamesMatch matches `addOneFV` choiceAName
  869 methodNamesCmd (HsCmdLamCase _ matches)
  870   = methodNamesMatch matches `addOneFV` choiceAName
  871 
  872 --methodNamesCmd _ = emptyFVs
  873    -- Other forms can't occur in commands, but it's not convenient
  874    -- to error here so we just do what's convenient.
  875    -- The type checker will complain later
  876 
  877 ---------------------------------------------------
  878 methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
  879 methodNamesMatch (MG { mg_alts = L _ ms })
  880   = plusFVs (map do_one ms)
  881  where
  882     do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
  883 
  884 -------------------------------------------------
  885 -- gaw 2004
  886 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
  887 methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
  888 
  889 -------------------------------------------------
  890 
  891 methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
  892 methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
  893 
  894 ---------------------------------------------------
  895 methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars
  896 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
  897 
  898 ---------------------------------------------------
  899 methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
  900 methodNamesLStmt = methodNamesStmt . unLoc
  901 
  902 methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
  903 methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
  904 methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
  905 methodNamesStmt (BindStmt _ _ cmd)             = methodNamesLCmd cmd
  906 methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =
  907   methodNamesStmts stmts `addOneFV` loopAName
  908 methodNamesStmt (LetStmt {})                   = emptyFVs
  909 methodNamesStmt (ParStmt {})                   = emptyFVs
  910 methodNamesStmt (TransStmt {})                 = emptyFVs
  911 methodNamesStmt ApplicativeStmt{}              = emptyFVs
  912    -- ParStmt and TransStmt can't occur in commands, but it's not
  913    -- convenient to error here so we just do what's convenient
  914 
  915 {-
  916 ************************************************************************
  917 *                                                                      *
  918         Arithmetic sequences
  919 *                                                                      *
  920 ************************************************************************
  921 -}
  922 
  923 rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
  924 rnArithSeq (From expr)
  925  = do { (expr', fvExpr) <- rnLExpr expr
  926       ; return (From expr', fvExpr) }
  927 
  928 rnArithSeq (FromThen expr1 expr2)
  929  = do { (expr1', fvExpr1) <- rnLExpr expr1
  930       ; (expr2', fvExpr2) <- rnLExpr expr2
  931       ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
  932 
  933 rnArithSeq (FromTo expr1 expr2)
  934  = do { (expr1', fvExpr1) <- rnLExpr expr1
  935       ; (expr2', fvExpr2) <- rnLExpr expr2
  936       ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
  937 
  938 rnArithSeq (FromThenTo expr1 expr2 expr3)
  939  = do { (expr1', fvExpr1) <- rnLExpr expr1
  940       ; (expr2', fvExpr2) <- rnLExpr expr2
  941       ; (expr3', fvExpr3) <- rnLExpr expr3
  942       ; return (FromThenTo expr1' expr2' expr3',
  943                 plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
  944 
  945 {-
  946 ************************************************************************
  947 *                                                                      *
  948 \subsubsection{@Stmt@s: in @do@ expressions}
  949 *                                                                      *
  950 ************************************************************************
  951 -}
  952 
  953 {-
  954 Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
  955 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  956 Both ApplicativeDo and RecursiveDo need to create tuples not
  957 present in the source text.
  958 
  959 For ApplicativeDo we create:
  960 
  961   (a,b,c) <- (\c b a -> (a,b,c)) <$>
  962 
  963 For RecursiveDo we create:
  964 
  965   mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
  966 
  967 The order of the components in those tuples needs to be stable
  968 across recompilations, otherwise they can get optimized differently
  969 and we end up with incompatible binaries.
  970 To get a stable order we use nameSetElemsStable.
  971 See Note [Deterministic UniqFM] to learn more about nondeterminism.
  972 -}
  973 
  974 type AnnoBody body
  975   = ( Outputable (body GhcPs)
  976     , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
  977     , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
  978     , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
  979     )
  980 
  981 -- | Rename some Stmts
  982 rnStmts :: AnnoBody body
  983         => HsStmtContext GhcRn
  984         -> (body GhcPs -> RnM (body GhcRn, FreeVars))
  985            -- ^ How to rename the body of each statement (e.g. rnLExpr)
  986         -> [LStmt GhcPs (LocatedA (body GhcPs))]
  987            -- ^ Statements
  988         -> ([Name] -> RnM (thing, FreeVars))
  989            -- ^ if these statements scope over something, this renames it
  990            -- and returns the result.
  991         -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
  992 rnStmts ctxt rnBody stmts thing_inside
  993  = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
  994       ; return ((map fst stmts', thing), fvs) }
  995 
  996 -- | maybe rearrange statements according to the ApplicativeDo transformation
  997 postProcessStmtsForApplicativeDo
  998   :: HsDoFlavour
  999   -> [(ExprLStmt GhcRn, FreeVars)]
 1000   -> RnM ([ExprLStmt GhcRn], FreeVars)
 1001 postProcessStmtsForApplicativeDo ctxt stmts
 1002   = do {
 1003        -- rearrange the statements using ApplicativeStmt if
 1004        -- -XApplicativeDo is on.  Also strip out the FreeVars attached
 1005        -- to each Stmt body.
 1006          ado_is_on <- xoptM LangExt.ApplicativeDo
 1007        ; let is_do_expr | DoExpr{} <- ctxt = True
 1008                         | otherwise = False
 1009        -- don't apply the transformation inside TH brackets, because
 1010        -- GHC.HsToCore.Quote does not handle ApplicativeDo.
 1011        ; in_th_bracket <- isBrackStage <$> getStage
 1012        ; if ado_is_on && is_do_expr && not in_th_bracket
 1013             then do { traceRn "ppsfa" (ppr stmts)
 1014                     ; rearrangeForApplicativeDo ctxt stmts }
 1015             else noPostProcessStmts (HsDoStmt ctxt) stmts }
 1016 
 1017 -- | strip the FreeVars annotations from statements
 1018 noPostProcessStmts
 1019   :: HsStmtContext GhcRn
 1020   -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
 1021   -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
 1022 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
 1023 
 1024 
 1025 rnStmtsWithFreeVars :: AnnoBody body
 1026         => HsStmtContext GhcRn
 1027         -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
 1028         -> [LStmt GhcPs (LocatedA (body GhcPs))]
 1029         -> ([Name] -> RnM (thing, FreeVars))
 1030         -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
 1031                , FreeVars)
 1032 -- Each Stmt body is annotated with its FreeVars, so that
 1033 -- we can rearrange statements for ApplicativeDo.
 1034 --
 1035 -- Variables bound by the Stmts, and mentioned in thing_inside,
 1036 -- do not appear in the result FreeVars
 1037 
 1038 rnStmtsWithFreeVars ctxt _ [] thing_inside
 1039   = do { checkEmptyStmts ctxt
 1040        ; (thing, fvs) <- thing_inside []
 1041        ; return (([], thing), fvs) }
 1042 
 1043 rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside    -- Deal with mdo
 1044   = -- Behave like do { rec { ...all but last... }; last }
 1045     do { ((stmts1, (stmts2, thing)), fvs)
 1046            <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->
 1047               do { last_stmt' <- checkLastStmt mDoExpr last_stmt
 1048                  ; rnStmt mDoExpr rnBody last_stmt' thing_inside }
 1049         ; return (((stmts1 ++ stmts2), thing), fvs) }
 1050   where
 1051     Just (all_but_last, last_stmt) = snocView stmts
 1052 
 1053 rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
 1054   | null lstmts
 1055   = setSrcSpanA loc $
 1056     do { lstmt' <- checkLastStmt ctxt lstmt
 1057        ; rnStmt ctxt rnBody lstmt' thing_inside }
 1058 
 1059   | otherwise
 1060   = do { ((stmts1, (stmts2, thing)), fvs)
 1061             <- setSrcSpanA loc                  $
 1062                do { checkStmt ctxt lstmt
 1063                   ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
 1064                     rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
 1065                     thing_inside (bndrs1 ++ bndrs2) }
 1066         ; return (((stmts1 ++ stmts2), thing), fvs) }
 1067 
 1068 ----------------------
 1069 
 1070 {-
 1071 Note [Failing pattern matches in Stmts]
 1072 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1073 
 1074 Many things desugar to HsStmts including monadic things like `do` and `mdo`
 1075 statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
 1076 exhaustive list). How we deal with pattern match failure is context-dependent.
 1077 
 1078  * In the case of list comprehensions and pattern guards we don't need any
 1079    'fail' function; the desugarer ignores the fail function of 'BindStmt'
 1080    entirely. So, for list comprehensions, the fail function is set to 'Nothing'
 1081    for clarity.
 1082 
 1083 * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
 1084    expressions) we want pattern match failure to be desugared to the
 1085    'fail' function (from MonadFail type class).
 1086 
 1087 At one point we failed to make this distinction, leading to #11216.
 1088 -}
 1089 
 1090 rnStmt :: AnnoBody body
 1091        => HsStmtContext GhcRn
 1092        -> (body GhcPs -> RnM (body GhcRn, FreeVars))
 1093           -- ^ How to rename the body of the statement
 1094        -> LStmt GhcPs (LocatedA (body GhcPs))
 1095           -- ^ The statement
 1096        -> ([Name] -> RnM (thing, FreeVars))
 1097           -- ^ Rename the stuff that this statement scopes over
 1098        -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
 1099               , FreeVars)
 1100 -- Variables bound by the Stmt, and mentioned in thing_inside,
 1101 -- do not appear in the result FreeVars
 1102 
 1103 rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
 1104   = do  { (body', fv_expr) <- rnBody body
 1105         ; (ret_op, fvs1) <- if isMonadCompContext ctxt
 1106                             then lookupStmtName ctxt returnMName
 1107                             else return (noSyntaxExpr, emptyFVs)
 1108                             -- The 'return' in a LastStmt is used only
 1109                             -- for MonadComp; and we don't want to report
 1110                             -- "non in scope: return" in other cases
 1111                             -- #15607
 1112 
 1113         ; (thing,  fvs3) <- thing_inside []
 1114         ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)]
 1115                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
 1116 
 1117 rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside
 1118   = do  { (body', fv_expr) <- rnBody body
 1119         ; (then_op, fvs1)  <- lookupQualifiedDoStmtName ctxt thenMName
 1120 
 1121         ; (guard_op, fvs2) <- if isComprehensionContext ctxt
 1122                               then lookupStmtName ctxt guardMName
 1123                               else return (noSyntaxExpr, emptyFVs)
 1124                               -- Only list/monad comprehensions use 'guard'
 1125                               -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
 1126                               -- Here "gd" is a guard
 1127 
 1128         ; (thing, fvs3)    <- thing_inside []
 1129         ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)]
 1130                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 1131 
 1132 rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside
 1133   = do  { (body', fv_expr) <- rnBody body
 1134                 -- The binders do not scope over the expression
 1135         ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
 1136 
 1137         ; (fail_op, fvs2) <- monadFailOp pat ctxt
 1138 
 1139         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 1140         { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')
 1141         ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
 1142         ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]
 1143                   , thing),
 1144                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 1145        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 1146         -- but it does not matter because the names are unique
 1147 
 1148 rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside
 1149   =     rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
 1150         { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds')
 1151         ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)
 1152                  , fvs) }
 1153 
 1154 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside
 1155   = do  { (return_op, fvs1)  <- lookupQualifiedDoStmtName ctxt returnMName
 1156         ; (mfix_op,   fvs2)  <- lookupQualifiedDoStmtName ctxt mfixName
 1157         ; (bind_op,   fvs3)  <- lookupQualifiedDoStmtName ctxt bindMName
 1158         ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
 1159                                                 , recS_mfix_fn = mfix_op
 1160                                                 , recS_bind_fn = bind_op }
 1161 
 1162         -- Step1: Bring all the binders of the mdo into scope
 1163         -- (Remember that this also removes the binders from the
 1164         -- finally-returned free-vars.)
 1165         -- And rename each individual stmt, making a
 1166         -- singleton segment.  At this stage the FwdRefs field
 1167         -- isn't finished: it's empty for all except a BindStmt
 1168         -- for which it's the fwd refs within the bind itself
 1169         -- (This set may not be empty, because we're in a recursive
 1170         -- context.)
 1171         ; rnRecStmtsAndThen ctxt rnBody rec_stmts   $ \ segs -> do
 1172         { let bndrs = nameSetElemsStable $
 1173                         foldr (unionNameSet . (\(ds,_,_,_) -> ds))
 1174                               emptyNameSet
 1175                               segs
 1176           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
 1177         ; (thing, fvs_later) <- thing_inside bndrs
 1178         -- In interactive mode, assume that all variables are used later
 1179         ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv
 1180         ; let
 1181              final_fvs_later = if is_interactive then Nothing else Just fvs_later
 1182              (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs final_fvs_later
 1183         -- We aren't going to try to group RecStmts with
 1184         -- ApplicativeDo, so attaching empty FVs is fine.
 1185         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
 1186                  , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 1187 
 1188 rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
 1189   = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
 1190         ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
 1191         ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
 1192         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
 1193         ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)
 1194                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 1195 
 1196 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
 1197                               , trS_using = using })) thing_inside
 1198   = do { -- Rename the 'using' expression in the context before the transform is begun
 1199          (using', fvs1) <- rnLExpr using
 1200 
 1201          -- Rename the stmts and the 'by' expression
 1202          -- Keep track of the variables mentioned in the 'by' expression
 1203        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 1204              <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs ->
 1205                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 1206                    ; (thing, fvs_thing) <- thing_inside bndrs
 1207                    ; let fvs = fvs_by `plusFV` fvs_thing
 1208                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 1209                          -- The paper (Fig 5) has a bug here; we must treat any free variable
 1210                          -- of the "thing inside", **or of the by-expression**, as used
 1211                    ; return ((by', used_bndrs, thing), fvs) }
 1212 
 1213        -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
 1214        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
 1215        ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
 1216        ; (fmap_op,   fvs5) <- case form of
 1217                                 ThenForm -> return (noExpr, emptyFVs)
 1218                                 _        -> lookupStmtNamePoly ctxt fmapName
 1219 
 1220        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
 1221                              `plusFV` fvs4 `plusFV` fvs5
 1222              bndr_map = used_bndrs `zip` used_bndrs
 1223              -- See Note [TransStmt binder map] in GHC.Hs.Expr
 1224 
 1225        ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
 1226        ; return (([(L loc (TransStmt { trS_ext = noExtField
 1227                                     , trS_stmts = stmts', trS_bndrs = bndr_map
 1228                                     , trS_by = by', trS_using = using', trS_form = form
 1229                                     , trS_ret = return_op, trS_bind = bind_op
 1230                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
 1231 
 1232 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
 1233   panic "rnStmt: ApplicativeStmt"
 1234 
 1235 rnParallelStmts :: forall thing. HsStmtContext GhcRn
 1236                 -> SyntaxExpr GhcRn
 1237                 -> [ParStmtBlock GhcPs GhcPs]
 1238                 -> ([Name] -> RnM (thing, FreeVars))
 1239                 -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
 1240 -- Note [Renaming parallel Stmts]
 1241 rnParallelStmts ctxt return_op segs thing_inside
 1242   = do { orig_lcl_env <- getLocalRdrEnv
 1243        ; rn_segs orig_lcl_env [] segs }
 1244   where
 1245     rn_segs :: LocalRdrEnv
 1246             -> [Name] -> [ParStmtBlock GhcPs GhcPs]
 1247             -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
 1248     rn_segs _ bndrs_so_far []
 1249       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 1250            ; mapM_ dupErr dups
 1251            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 1252            ; return (([], thing), fvs) }
 1253 
 1254     rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
 1255       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 1256                     <- rnStmts ctxt rnExpr stmts $ \ bndrs ->
 1257                        setLocalRdrEnv env       $ do
 1258                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 1259                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 1260                        ; return ((used_bndrs, segs', thing), fvs) }
 1261 
 1262            ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
 1263            ; return ((seg':segs', thing), fvs) }
 1264 
 1265     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 1266     dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
 1267                   (text "Duplicate binding in parallel list comprehension for:"
 1268                     <+> quotes (ppr (NE.head vs)))
 1269 
 1270 lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
 1271 -- Like lookupStmtName, but respects QualifiedDo
 1272 lookupQualifiedDoStmtName ctxt n
 1273   = case qualifiedDoModuleName_maybe ctxt of
 1274       Nothing -> lookupStmtName ctxt n
 1275       Just modName ->
 1276         first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
 1277 
 1278 lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
 1279 -- Like lookupSyntax, but respects contexts
 1280 lookupStmtName ctxt n
 1281   | rebindableContext ctxt
 1282   = lookupSyntax n
 1283   | otherwise
 1284   = return (mkRnSyntaxExpr n, emptyFVs)
 1285 
 1286 lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
 1287 lookupStmtNamePoly ctxt name
 1288   | rebindableContext ctxt
 1289   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
 1290        ; if rebindable_on
 1291          then do { fm <- lookupOccRn (nameRdrName name)
 1292                  ; return (HsVar noExtField (noLocA fm), unitFV fm) }
 1293          else not_rebindable }
 1294   | otherwise
 1295   = not_rebindable
 1296   where
 1297     not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)
 1298 
 1299 -- | Is this a context where we respect RebindableSyntax?
 1300 -- but ListComp are never rebindable
 1301 -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
 1302 rebindableContext :: HsStmtContext GhcRn -> Bool
 1303 rebindableContext ctxt = case ctxt of
 1304   HsDoStmt flavour -> rebindableDoStmtContext flavour
 1305   ArrowExpr -> False
 1306   PatGuard {} -> False
 1307 
 1308 
 1309   ParStmtCtxt   c -> rebindableContext c     -- Look inside to
 1310   TransStmtCtxt c -> rebindableContext c     -- the parent context
 1311 
 1312 rebindableDoStmtContext :: HsDoFlavour -> Bool
 1313 rebindableDoStmtContext flavour = case flavour of
 1314   ListComp -> False
 1315   DoExpr m -> isNothing m
 1316   MDoExpr m -> isNothing m
 1317   MonadComp -> True
 1318   GhciStmtCtxt -> True   -- I suppose?
 1319 
 1320 {-
 1321 Note [Renaming parallel Stmts]
 1322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1323 Renaming parallel statements is painful.  Given, say
 1324      [ a+c | a <- as, bs <- bss
 1325            | c <- bs, a <- ds ]
 1326 Note that
 1327   (a) In order to report "Defined but not used" about 'bs', we must
 1328       rename each group of Stmts with a thing_inside whose FreeVars
 1329       include at least {a,c}
 1330 
 1331   (b) We want to report that 'a' is illegally bound in both branches
 1332 
 1333   (c) The 'bs' in the second group must obviously not be captured by
 1334       the binding in the first group
 1335 
 1336 To satisfy (a) we nest the segements.
 1337 To satisfy (b) we check for duplicates just before thing_inside.
 1338 To satisfy (c) we reset the LocalRdrEnv each time.
 1339 
 1340 ************************************************************************
 1341 *                                                                      *
 1342 \subsubsection{mdo expressions}
 1343 *                                                                      *
 1344 ************************************************************************
 1345 -}
 1346 
 1347 type FwdRefs = NameSet
 1348 type Segment stmts = (Defs,
 1349                       Uses,     -- May include defs
 1350                       FwdRefs,  -- A subset of uses that are
 1351                                 --   (a) used before they are bound in this segment, or
 1352                                 --   (b) used here, and bound in subsequent segments
 1353                       stmts)    -- Either Stmt or [Stmt]
 1354 
 1355 
 1356 -- wrapper that does both the left- and right-hand sides
 1357 rnRecStmtsAndThen :: AnnoBody body =>
 1358                      HsStmtContext GhcRn
 1359                   -> (body GhcPs -> RnM (body GhcRn, FreeVars))
 1360                   -> [LStmt GhcPs (LocatedA (body GhcPs))]
 1361                          -- assumes that the FreeVars returned includes
 1362                          -- the FreeVars of the Segments
 1363                   -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
 1364                       -> RnM (a, FreeVars))
 1365                   -> RnM (a, FreeVars)
 1366 rnRecStmtsAndThen ctxt rnBody s cont
 1367   = do  { -- (A) Make the mini fixity env for all of the stmts
 1368           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 1369 
 1370           -- (B) Do the LHSes
 1371         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 1372 
 1373           --    ...bring them and their fixities into scope
 1374         ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)
 1375               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
 1376               rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
 1377               implicit_uses = mkNameSet $ concatMap snd $ rec_uses
 1378         ; bindLocalNamesFV bound_names $
 1379           addLocalFixities fix_env bound_names $ do
 1380 
 1381           -- (C) do the right-hand-sides and thing-inside
 1382         { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv
 1383         ; (res, fvs) <- cont segs
 1384         ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
 1385                 rec_uses
 1386         ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
 1387         ; return (res, fvs) }}
 1388 
 1389 -- get all the fixity decls in any Let stmt
 1390 collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
 1391 collectRecStmtsFixities l =
 1392     foldr (\ s -> \acc -> case s of
 1393             (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->
 1394               foldr (\ sig -> \ acc -> case sig of
 1395                                          (L loc (FixSig _ s)) -> (L loc s) : acc
 1396                                          _ -> acc) acc sigs
 1397             _ -> acc) [] l
 1398 
 1399 -- left-hand sides
 1400 
 1401 rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv
 1402                 -> LStmt GhcPs (LocatedA (body GhcPs))
 1403                    -- rename LHS, and return its FVs
 1404                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 1405                    -- so we don't bother to compute it accurately in the other cases
 1406                 -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
 1407 
 1408 rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
 1409   = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]
 1410 
 1411 rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
 1412   = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
 1413 
 1414 rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
 1415   = do
 1416       -- should the ctxt be MDo instead?
 1417       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 1418       return [(L loc (BindStmt noAnn pat' body), fv_pat)]
 1419 
 1420 rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {})))
 1421   = failWith (badIpBinds (text "an mdo expression") binds)
 1422 
 1423 rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))
 1424     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
 1425          return [(L loc (LetStmt noAnn (HsValBinds x binds')),
 1426                  -- Warning: this is bogus; see function invariant
 1427                  emptyFVs
 1428                  )]
 1429 
 1430 -- XXX Do we need to do something with the return and mfix names?
 1431 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts }))  -- Flatten Rec inside Rec
 1432     = rn_rec_stmts_lhs fix_env stmts
 1433 
 1434 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
 1435   = pprPanic "rn_rec_stmt" (ppr stmt)
 1436 
 1437 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
 1438   = pprPanic "rn_rec_stmt" (ppr stmt)
 1439 
 1440 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
 1441   = pprPanic "rn_rec_stmt" (ppr stmt)
 1442 
 1443 rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
 1444   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 1445 
 1446 rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv
 1447                  -> [LStmt GhcPs (LocatedA (body GhcPs))]
 1448                  -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
 1449 rn_rec_stmts_lhs fix_env stmts
 1450   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 1451        ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls)
 1452             -- First do error checking: we need to check for dups here because we
 1453             -- don't bind all of the variables from the Stmt at once
 1454             -- with bindLocatedLocals.
 1455        ; checkDupNames boundNames
 1456        ; return ls }
 1457 
 1458 
 1459 -- right-hand-sides
 1460 
 1461 rn_rec_stmt :: AnnoBody body =>
 1462                HsStmtContext GhcRn
 1463             -> (body GhcPs -> RnM (body GhcRn, FreeVars))
 1464             -> [Name]
 1465             -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
 1466             -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
 1467         -- Rename a Stmt that is inside a RecStmt (or mdo)
 1468         -- Assumes all binders are already in scope
 1469         -- Turns each stmt into a singleton Stmt
 1470 rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _)
 1471   = do  { (body', fv_expr) <- rnBody body
 1472         ; (ret_op, fvs1)   <- lookupQualifiedDo ctxt returnMName
 1473         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
 1474                    L loc (LastStmt noExtField (L lb body') noret ret_op))] }
 1475 
 1476 rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _)
 1477   = do { (body', fvs) <- rnBody body
 1478        ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName
 1479        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 1480                  L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] }
 1481 
 1482 rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat)
 1483   = do { (body', fv_expr) <- rnBody body
 1484        ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
 1485 
 1486        ; (fail_op, fvs2) <- getMonadFailOp ctxt
 1487 
 1488        ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat')
 1489              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 1490        ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
 1491        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 1492                   L loc (BindStmt xbsrn pat' (L lb body')))] }
 1493 
 1494 rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _)
 1495   = failWith (badIpBinds (text "an mdo expression") binds)
 1496 
 1497 rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _)
 1498   = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
 1499            -- fixities and unused are handled above in rnRecStmtsAndThen
 1500        ; let fvs = allUses du_binds
 1501        ; return [(duDefs du_binds, fvs, emptyNameSet,
 1502                  L loc (LetStmt noAnn (HsValBinds x binds')))] }
 1503 
 1504 -- no RecStmt case because they get flattened above when doing the LHSes
 1505 rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)
 1506   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
 1507 
 1508 rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
 1509   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
 1510 
 1511 rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
 1512   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
 1513 
 1514 rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
 1515   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
 1516 
 1517 rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
 1518   = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
 1519 
 1520 rn_rec_stmts :: AnnoBody body =>
 1521                 HsStmtContext GhcRn
 1522              -> (body GhcPs -> RnM (body GhcRn, FreeVars))
 1523              -> [Name]
 1524              -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
 1525              -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
 1526 rn_rec_stmts ctxt rnBody bndrs stmts
 1527   = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts
 1528        ; return (concat segs_s) }
 1529 
 1530 ---------------------------------------------
 1531 segmentRecStmts :: AnnoBody body
 1532                 => SrcSpan -> HsStmtContext GhcRn
 1533                 -> Stmt GhcRn (LocatedA (body GhcRn))
 1534                 -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
 1535                 -> Maybe FreeVars -- Nothing when in interactive mode, everything can be used later
 1536                                   -- Note [What is "used later" in a rec stmt]
 1537                 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
 1538 
 1539 segmentRecStmts loc ctxt empty_rec_stmt segs mfvs_later
 1540   | null segs
 1541   = ([], final_fv_uses)
 1542 
 1543   | HsDoStmt (MDoExpr _) <- ctxt
 1544   = segsToStmts empty_rec_stmt grouped_segs later_ids
 1545                -- Step 4: Turn the segments into Stmts
 1546                 --         Use RecStmt when and only when there are fwd refs
 1547                 --         Also gather up the uses from the end towards the
 1548                 --         start, so we can tell the RecStmt which things are
 1549                 --         used 'after' the RecStmt
 1550 
 1551   | otherwise
 1552   = ([ L (noAnnSrcSpan loc) $
 1553        empty_rec_stmt { recS_stmts = noLocA ss
 1554                       , recS_later_ids = nameSetElemsStable later_ids
 1555                       , recS_rec_ids   = nameSetElemsStable
 1556                                            (defs `intersectNameSet` uses) }]
 1557           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
 1558     , uses `plusFV` final_fv_uses)
 1559 
 1560   where
 1561     final_fv_uses = case mfvs_later of
 1562                   Nothing -> defs
 1563                   Just later -> uses `plusFV` later
 1564     later_ids = case mfvs_later of
 1565                   Nothing -> defs
 1566                   Just fvs_later -> defs `intersectNameSet` fvs_later
 1567 
 1568     (defs_s, uses_s, _, ss) = unzip4 segs
 1569     defs = plusFVs defs_s
 1570     uses = plusFVs uses_s
 1571 
 1572                 -- Step 2: Fill in the fwd refs.
 1573                 --         The segments are all singletons, but their fwd-ref
 1574                 --         field mentions all the things used by the segment
 1575                 --         that are bound after their use
 1576     segs_w_fwd_refs = addFwdRefs segs
 1577 
 1578                 -- Step 3: Group together the segments to make bigger segments
 1579                 --         Invariant: in the result, no segment uses a variable
 1580                 --                    bound in a later segment
 1581     grouped_segs = glomSegments ctxt segs_w_fwd_refs
 1582 
 1583 ----------------------------
 1584 addFwdRefs :: [Segment a] -> [Segment a]
 1585 -- So far the segments only have forward refs *within* the Stmt
 1586 --      (which happens for bind:  x <- ...x...)
 1587 -- This function adds the cross-seg fwd ref info
 1588 
 1589 addFwdRefs segs
 1590   = fst (foldr mk_seg ([], emptyNameSet) segs)
 1591   where
 1592     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
 1593         = (new_seg : segs, all_defs)
 1594         where
 1595           new_seg = (defs, uses, new_fwds, stmts)
 1596           all_defs = later_defs `unionNameSet` defs
 1597           new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
 1598                 -- Add the downstream fwd refs here
 1599 
 1600 {-
 1601 Note [Segmenting mdo]
 1602 ~~~~~~~~~~~~~~~~~~~~~
 1603 NB. June 7 2012: We only glom segments that appear in an explicit mdo;
 1604 and leave those found in "do rec"'s intact.  See
 1605 https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion
 1606 leading to this design choice.  Hence the test in segmentRecStmts.
 1607 
 1608 Note [Glomming segments]
 1609 ~~~~~~~~~~~~~~~~~~~~~~~~
 1610 Glomming the singleton segments of an mdo into minimal recursive groups.
 1611 
 1612 At first I thought this was just strongly connected components, but
 1613 there's an important constraint: the order of the stmts must not change.
 1614 
 1615 Consider
 1616      mdo { x <- ...y...
 1617            p <- z
 1618            y <- ...x...
 1619            q <- x
 1620            z <- y
 1621            r <- x }
 1622 
 1623 Here, the first stmt mention 'y', which is bound in the third.
 1624 But that means that the innocent second stmt (p <- z) gets caught
 1625 up in the recursion.  And that in turn means that the binding for
 1626 'z' has to be included... and so on.
 1627 
 1628 Start at the tail { r <- x }
 1629 Now add the next one { z <- y ; r <- x }
 1630 Now add one more     { q <- x ; z <- y ; r <- x }
 1631 Now one more... but this time we have to group a bunch into rec
 1632      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 1633 Now one more, which we can add on without a rec
 1634      { p <- z ;
 1635        rec { y <- ...x... ; q <- x ; z <- y } ;
 1636        r <- x }
 1637 Finally we add the last one; since it mentions y we have to
 1638 glom it together with the first two groups
 1639      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 1640              q <- x ; z <- y } ;
 1641        r <- x }
 1642 
 1643 Note [What is "used later" in a rec stmt]
 1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1645 We desugar a recursive Stmt to somethign like
 1646 
 1647   (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })
 1648   ...stuff after the rec...
 1649 
 1650 The knot-tied tuple must contain
 1651 * All the variables that are used before they are bound in the `rec` block
 1652 * All the variables that are used after the entire `rec` block
 1653 
 1654 In the case of GHCi, however, we don't know what variables will be used
 1655 after the `rec` (#20206).  For example, we might have
 1656     ghci>  rec { x <- e1; y <- e2 }
 1657     ghci>  print x
 1658     ghci>  print y
 1659 
 1660 So we have to assume that *all* the variables bound in the `rec` are used
 1661 afterwards.  We use `Nothing` in the argument to segmentRecStmts to signal
 1662 that all the variables are used.
 1663 -}
 1664 
 1665 glomSegments :: HsStmtContext GhcRn
 1666              -> [Segment (LStmt GhcRn body)]
 1667              -> [Segment [LStmt GhcRn body]]
 1668                                   -- Each segment has a non-empty list of Stmts
 1669 -- See Note [Glomming segments]
 1670 
 1671 glomSegments _ [] = []
 1672 glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
 1673         -- Actually stmts will always be a singleton
 1674   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 1675   where
 1676     segs'            = glomSegments ctxt segs
 1677     (extras, others) = grab uses segs'
 1678     (ds, us, fs, ss) = unzip4 extras
 1679 
 1680     seg_defs  = plusFVs ds `plusFV` defs
 1681     seg_uses  = plusFVs us `plusFV` uses
 1682     seg_fwds  = plusFVs fs `plusFV` fwds
 1683     seg_stmts = stmt : concat ss
 1684 
 1685     grab :: NameSet             -- The client
 1686          -> [Segment a]
 1687          -> ([Segment a],       -- Needed by the 'client'
 1688              [Segment a])       -- Not needed by the client
 1689         -- The result is simply a split of the input
 1690     grab uses dus
 1691         = (reverse yeses, reverse noes)
 1692         where
 1693           (noes, yeses)           = span not_needed (reverse dus)
 1694           not_needed (defs,_,_,_) = disjointNameSet defs uses
 1695 
 1696 ----------------------------------------------------
 1697 segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
 1698                                   -- A RecStmt with the SyntaxOps filled in
 1699             -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
 1700                                   -- Each Segment has a non-empty list of Stmts
 1701             -> FreeVars           -- Free vars used 'later'
 1702             -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
 1703 
 1704 segsToStmts _ [] fvs_later = ([], fvs_later)
 1705 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
 1706   = assert (not (null ss))
 1707     (new_stmt : later_stmts, later_uses `plusFV` uses)
 1708   where
 1709     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
 1710     new_stmt | non_rec   = head ss
 1711              | otherwise = L (getLoc (head ss)) rec_stmt
 1712     rec_stmt = empty_rec_stmt { recS_stmts     = noLocA ss
 1713                               , recS_later_ids = nameSetElemsStable used_later
 1714                               , recS_rec_ids   = nameSetElemsStable fwds }
 1715           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
 1716     non_rec    = isSingleton ss && isEmptyNameSet fwds
 1717     used_later = defs `intersectNameSet` later_uses
 1718                                 -- The ones needed after the RecStmt
 1719 
 1720 {-
 1721 ************************************************************************
 1722 *                                                                      *
 1723 ApplicativeDo
 1724 *                                                                      *
 1725 ************************************************************************
 1726 
 1727 Note [ApplicativeDo]
 1728 
 1729 = Example =
 1730 
 1731 For a sequence of statements
 1732 
 1733  do
 1734      x <- A
 1735      y <- B x
 1736      z <- C
 1737      return (f x y z)
 1738 
 1739 We want to transform this to
 1740 
 1741   (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
 1742 
 1743 It would be easy to notice that "y <- B x" and "z <- C" are
 1744 independent and do something like this:
 1745 
 1746  do
 1747      x <- A
 1748      (y,z) <- (,) <$> B x <*> C
 1749      return (f x y z)
 1750 
 1751 But this isn't enough! A and C were also independent, and this
 1752 transformation loses the ability to do A and C in parallel.
 1753 
 1754 The algorithm works by first splitting the sequence of statements into
 1755 independent "segments", and a separate "tail" (the final statement). In
 1756 our example above, the segements would be
 1757 
 1758      [ x <- A
 1759      , y <- B x ]
 1760 
 1761      [ z <- C ]
 1762 
 1763 and the tail is:
 1764 
 1765      return (f x y z)
 1766 
 1767 Then we take these segments and make an Applicative expression from them:
 1768 
 1769      (\(x,y) z -> return (f x y z))
 1770        <$> do { x <- A; y <- B x; return (x,y) }
 1771        <*> C
 1772 
 1773 Finally, we recursively apply the transformation to each segment, to
 1774 discover any nested parallelism.
 1775 
 1776 = Syntax & spec =
 1777 
 1778   expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
 1779 
 1780   stmt ::= pat <- expr
 1781          | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
 1782          | ...                    -- other kinds of statement (e.g. let)
 1783 
 1784   arg ::= pat <- expr
 1785         | {stmt_1; ..; stmt_n} {var_1..var_n}
 1786 
 1787 (note that in the actual implementation,the expr in a do statement is
 1788 represented by a LastStmt as the final stmt, this is just a
 1789 representational issue and may change later.)
 1790 
 1791 == Transformation to introduce applicative stmts ==
 1792 
 1793 ado {} tail = tail
 1794 ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
 1795 ado {one} tail = one : tail
 1796 ado stmts tail
 1797   | n == 1 = ado before (ado after tail)
 1798     where (before,after) = split(stmts_1)
 1799   | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
 1800   where
 1801     {stmts_1 .. stmts_n} = segments(stmts)
 1802 
 1803 segments(stmts) =
 1804   -- divide stmts into segments with no interdependencies
 1805 
 1806 mkArg({pat <- expr}) = (pat <- expr)
 1807 mkArg({stmt_1; ...; stmt_n}) =
 1808   {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
 1809 
 1810 split({stmt_1; ..; stmt_n) =
 1811   ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
 1812   -- 1 <= i <= n
 1813   -- i is a good place to insert a bind
 1814 
 1815 == Desugaring for do ==
 1816 
 1817 dsDo {} expr = expr
 1818 
 1819 dsDo {pat <- rhs; stmts} expr =
 1820    rhs >>= \pat -> dsDo stmts expr
 1821 
 1822 dsDo {(arg_1 | ... | arg_n)} (return expr) =
 1823   (\argpat (arg_1) .. argpat(arg_n) -> expr)
 1824      <$> argexpr(arg_1)
 1825      <*> ...
 1826      <*> argexpr(arg_n)
 1827 
 1828 dsDo {(arg_1 | ... | arg_n); stmts} expr =
 1829   join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
 1830      <$> argexpr(arg_1)
 1831      <*> ...
 1832      <*> argexpr(arg_n)
 1833 
 1834 = Relevant modules in the rest of the compiler =
 1835 
 1836 ApplicativeDo touches a few phases in the compiler:
 1837 
 1838 * Renamer: The journey begins here in the renamer, where do-blocks are
 1839   scheduled as outlined above and transformed into applicative
 1840   combinators.  However, the code is still represented as a do-block
 1841   with special forms of applicative statements. This allows us to
 1842   recover the original do-block when e.g. printing type errors, where
 1843   we don't want to show any of the applicative combinators since they
 1844   don't exist in the source code.
 1845   See ApplicativeStmt and ApplicativeArg in HsExpr.
 1846 
 1847 * Typechecker: ApplicativeDo passes through the typechecker much like any
 1848   other form of expression. The only crux is that the typechecker has to
 1849   be aware of the special ApplicativeDo statements in the do-notation, and
 1850   typecheck them appropriately.
 1851   Relevant module: GHC.Tc.Gen.Match
 1852 
 1853 * Desugarer: Any do-block which contains applicative statements is desugared
 1854   as outlined above, to use the Applicative combinators.
 1855   Relevant module: GHC.HsToCore.Expr
 1856 
 1857 -}
 1858 
 1859 -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
 1860 -- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@.
 1861 data MonadNames = MonadNames { return_name, pure_name :: Name }
 1862 
 1863 instance Outputable MonadNames where
 1864   ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =
 1865     hcat
 1866     [text "MonadNames { return_name = "
 1867     ,ppr return_name
 1868     ,text ", pure_name = "
 1869     ,ppr pure_name
 1870     ,text "}"
 1871     ]
 1872 
 1873 -- | rearrange a list of statements using ApplicativeDoStmt.  See
 1874 -- Note [ApplicativeDo].
 1875 rearrangeForApplicativeDo
 1876   :: HsDoFlavour
 1877   -> [(ExprLStmt GhcRn, FreeVars)]
 1878   -> RnM ([ExprLStmt GhcRn], FreeVars)
 1879 
 1880 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
 1881 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
 1882 rearrangeForApplicativeDo ctxt stmts0 = do
 1883   optimal_ado <- goptM Opt_OptimalApplicativeDo
 1884   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
 1885                 | otherwise = mkStmtTreeHeuristic stmts
 1886   traceRn "rearrangeForADo" (ppr stmt_tree)
 1887   (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
 1888   (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
 1889   let monad_names = MonadNames { return_name = return_name
 1890                                , pure_name   = pure_name }
 1891   stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
 1892   where
 1893     (stmts,(last,last_fvs)) = findLast stmts0
 1894     findLast [] = error "findLast"
 1895     findLast [last] = ([],last)
 1896     findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
 1897 
 1898 -- | A tree of statements using a mixture of applicative and bind constructs.
 1899 data StmtTree a
 1900   = StmtTreeOne a
 1901   | StmtTreeBind (StmtTree a) (StmtTree a)
 1902   | StmtTreeApplicative [StmtTree a]
 1903 
 1904 instance Outputable a => Outputable (StmtTree a) where
 1905   ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
 1906   ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
 1907                                             2 (sep [ppr x, ppr y]))
 1908   ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
 1909                                             2 (vcat (map ppr xs)))
 1910 
 1911 flattenStmtTree :: StmtTree a -> [a]
 1912 flattenStmtTree t = go t []
 1913  where
 1914   go (StmtTreeOne a) as = a : as
 1915   go (StmtTreeBind l r) as = go l (go r as)
 1916   go (StmtTreeApplicative ts) as = foldr go as ts
 1917 
 1918 type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
 1919 type Cost = Int
 1920 
 1921 -- | Turn a sequence of statements into an ExprStmtTree using a
 1922 -- heuristic algorithm.  /O(n^2)/
 1923 mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
 1924 mkStmtTreeHeuristic [one] = StmtTreeOne one
 1925 mkStmtTreeHeuristic stmts =
 1926   case segments stmts of
 1927     [one] -> split one
 1928     segs -> StmtTreeApplicative (map split segs)
 1929  where
 1930   split [one] = StmtTreeOne one
 1931   split stmts =
 1932     StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
 1933     where (before, after) = splitSegment stmts
 1934 
 1935 -- | Turn a sequence of statements into an ExprStmtTree optimally,
 1936 -- using dynamic programming.  /O(n^3)/
 1937 mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
 1938 mkStmtTreeOptimal stmts =
 1939   assert (not (null stmts)) $ -- the empty case is handled by the caller;
 1940                               -- we don't support empty StmtTrees.
 1941   fst (arr ! (0,n))
 1942   where
 1943     n = length stmts - 1
 1944     stmt_arr = listArray (0,n) stmts
 1945 
 1946     -- lazy cache of optimal trees for subsequences of the input
 1947     arr :: Array (Int,Int) (ExprStmtTree, Cost)
 1948     arr = array ((0,0),(n,n))
 1949              [ ((lo,hi), tree lo hi)
 1950              | lo <- [0..n]
 1951              , hi <- [lo..n] ]
 1952 
 1953     -- compute the optimal tree for the sequence [lo..hi]
 1954     tree lo hi
 1955       | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
 1956       | otherwise =
 1957          case segments [ stmt_arr ! i | i <- [lo..hi] ] of
 1958            [] -> panic "mkStmtTree"
 1959            [_one] -> split lo hi
 1960            segs -> (StmtTreeApplicative trees, maximum costs)
 1961              where
 1962                bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
 1963                (trees,costs) = unzip (map (uncurry split) (tail bounds))
 1964 
 1965     -- find the best place to split the segment [lo..hi]
 1966     split :: Int -> Int -> (ExprStmtTree, Cost)
 1967     split lo hi
 1968       | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
 1969       | otherwise = (StmtTreeBind before after, c1+c2)
 1970         where
 1971          -- As per the paper, for a sequence s1...sn, we want to find
 1972          -- the split with the minimum cost, where the cost is the
 1973          -- sum of the cost of the left and right subsequences.
 1974          --
 1975          -- As an optimisation (also in the paper) if the cost of
 1976          -- s1..s(n-1) is different from the cost of s2..sn, we know
 1977          -- that the optimal solution is the lower of the two.  Only
 1978          -- in the case that these two have the same cost do we need
 1979          -- to do the exhaustive search.
 1980          --
 1981          ((before,c1),(after,c2))
 1982            | hi - lo == 1
 1983            = ((StmtTreeOne (stmt_arr ! lo), 1),
 1984               (StmtTreeOne (stmt_arr ! hi), 1))
 1985            | left_cost < right_cost
 1986            = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
 1987            | left_cost > right_cost
 1988            = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
 1989            | otherwise = minimumBy (comparing cost) alternatives
 1990            where
 1991              (left, left_cost) = arr ! (lo,hi-1)
 1992              (right, right_cost) = arr ! (lo+1,hi)
 1993              cost ((_,c1),(_,c2)) = c1 + c2
 1994              alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
 1995                             | k <- [lo .. hi-1] ]
 1996 
 1997 
 1998 -- | Turn the ExprStmtTree back into a sequence of statements, using
 1999 -- ApplicativeStmt where necessary.
 2000 stmtTreeToStmts
 2001   :: MonadNames
 2002   -> HsDoFlavour
 2003   -> ExprStmtTree
 2004   -> [ExprLStmt GhcRn]             -- ^ the "tail"
 2005   -> FreeVars                     -- ^ free variables of the tail
 2006   -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
 2007          , FreeVars )             -- , things we needed
 2008 
 2009 -- If we have a single bind, and we can do it without a join, transform
 2010 -- to an ApplicativeStmt.  This corresponds to the rule
 2011 --   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
 2012 -- In the spec, but we do it here rather than in the desugarer,
 2013 -- because we need the typechecker to typecheck the <$> form rather than
 2014 -- the bind form, which would give rise to a Monad constraint.
 2015 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))
 2016                 tail _tail_fvs
 2017   | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
 2018   -- See Note [ApplicativeDo and strict patterns]
 2019   = mkApplicativeStmt ctxt [ApplicativeArgOne
 2020                             { xarg_app_arg_one = xbsrn_failOp xbs
 2021                             , app_arg_pattern  = pat
 2022                             , arg_expr         = rhs
 2023                             , is_body_stmt     = False
 2024                             }]
 2025                       False tail'
 2026 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
 2027                 tail _tail_fvs
 2028   | (False,tail') <- needJoin monad_names tail
 2029   = mkApplicativeStmt ctxt
 2030       [ApplicativeArgOne
 2031        { xarg_app_arg_one = Nothing
 2032        , app_arg_pattern  = nlWildPatName
 2033        , arg_expr         = rhs
 2034        , is_body_stmt     = True
 2035        }] False tail'
 2036 
 2037 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
 2038   return (s : tail, emptyNameSet)
 2039 
 2040 stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
 2041   (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
 2042   let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
 2043   (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
 2044   return (stmts2, fvs1 `plusFV` fvs2)
 2045 
 2046 stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
 2047    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
 2048    dflags <- getDynFlags
 2049    let (stmts', fvss) = unzip pairs
 2050    let (need_join, tail') =
 2051      -- See Note [ApplicativeDo and refutable patterns]
 2052          if any (hasRefutablePattern dflags) stmts'
 2053          then (True, tail)
 2054          else needJoin monad_names tail
 2055 
 2056    (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
 2057    return (stmts, unionNameSets (fvs:fvss))
 2058  where
 2059    stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
 2060      = return (ApplicativeArgOne
 2061                { xarg_app_arg_one = xbsrn_failOp xbs
 2062                , app_arg_pattern  = pat
 2063                , arg_expr         = exp
 2064                , is_body_stmt     = False
 2065                }, emptyFVs)
 2066    stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
 2067      return (ApplicativeArgOne
 2068              { xarg_app_arg_one = Nothing
 2069              , app_arg_pattern  = nlWildPatName
 2070              , arg_expr         = exp
 2071              , is_body_stmt     = True
 2072              }, emptyFVs)
 2073    stmtTreeArg ctxt tail_fvs tree = do
 2074      let stmts = flattenStmtTree tree
 2075          pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
 2076                      `intersectNameSet` tail_fvs
 2077          pvars = nameSetElemsStable pvarset
 2078            -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
 2079          pat = mkBigLHsVarPatTup pvars
 2080          tup = mkBigLHsVarTup pvars noExtField
 2081      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
 2082      (mb_ret, fvs1) <-
 2083         if | L _ ApplicativeStmt{} <- last stmts' ->
 2084              return (unLoc tup, emptyNameSet)
 2085            | otherwise -> do
 2086              (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName
 2087              let expr = HsApp noComments (noLocA ret) tup
 2088              return (expr, emptyFVs)
 2089      return ( ApplicativeArgMany
 2090               { xarg_app_arg_many = noExtField
 2091               , app_stmts         = stmts'
 2092               , final_expr        = mb_ret
 2093               , bv_pattern        = pat
 2094               , stmt_context      = ctxt
 2095               }
 2096             , fvs1 `plusFV` fvs2)
 2097 
 2098 
 2099 -- | Divide a sequence of statements into segments, where no segment
 2100 -- depends on any variables defined by a statement in another segment.
 2101 segments
 2102   :: [(ExprLStmt GhcRn, FreeVars)]
 2103   -> [[(ExprLStmt GhcRn, FreeVars)]]
 2104 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
 2105   where
 2106     allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
 2107 
 2108     -- We would rather not have a segment that just has LetStmts in
 2109     -- it, so combine those with an adjacent segment where possible.
 2110     merge [] = []
 2111     merge (seg : segs)
 2112        = case rest of
 2113           [] -> [(seg,all_lets)]
 2114           ((s,s_lets):ss) | all_lets || s_lets
 2115                -> (seg ++ s, all_lets && s_lets) : ss
 2116           _otherwise -> (seg,all_lets) : rest
 2117       where
 2118         rest = merge segs
 2119         all_lets = all (isLetStmt . fst) seg
 2120 
 2121     -- walk splits the statement sequence into segments, traversing
 2122     -- the sequence from the back to the front, and keeping track of
 2123     -- the set of free variables of the current segment.  Whenever
 2124     -- this set of free variables is empty, we have a complete segment.
 2125     walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
 2126     walk [] = []
 2127     walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
 2128       where (seg,rest) = chunter fvs' stmts
 2129             (_, fvs') = stmtRefs stmt fvs
 2130 
 2131     chunter _ [] = ([], [])
 2132     chunter vars ((stmt,fvs) : rest)
 2133        | not (isEmptyNameSet vars)
 2134        || isStrictPatternBind stmt
 2135            -- See Note [ApplicativeDo and strict patterns]
 2136        = ((stmt,fvs) : chunk, rest')
 2137        where (chunk,rest') = chunter vars' rest
 2138              (pvars, evars) = stmtRefs stmt fvs
 2139              vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
 2140     chunter _ rest = ([], rest)
 2141 
 2142     stmtRefs stmt fvs
 2143       | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
 2144       | otherwise      = (pvars, fvs')
 2145       where fvs' = fvs `intersectNameSet` allvars
 2146             pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))
 2147 
 2148     isStrictPatternBind :: ExprLStmt GhcRn -> Bool
 2149     isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
 2150     isStrictPatternBind _ = False
 2151 
 2152 {-
 2153 Note [ApplicativeDo and strict patterns]
 2154 
 2155 A strict pattern match is really a dependency.  For example,
 2156 
 2157 do
 2158   (x,y) <- A
 2159   z <- B
 2160   return C
 2161 
 2162 The pattern (_,_) must be matched strictly before we do B.  If we
 2163 allowed this to be transformed into
 2164 
 2165   (\(x,y) -> \z -> C) <$> A <*> B
 2166 
 2167 then it could be lazier than the standard desuraging using >>=.  See #13875
 2168 for more examples.
 2169 
 2170 Thus, whenever we have a strict pattern match, we treat it as a
 2171 dependency between that statement and the following one.  The
 2172 dependency prevents those two statements from being performed "in
 2173 parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
 2174 can do with the rest of the statements in the same "do" expression.
 2175 -}
 2176 
 2177 isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
 2178 isStrictPattern (L loc pat) =
 2179   case pat of
 2180     WildPat{}       -> False
 2181     VarPat{}        -> False
 2182     LazyPat{}       -> False
 2183     AsPat _ _ p     -> isStrictPattern p
 2184     ParPat _ _ p _  -> isStrictPattern p
 2185     ViewPat _ _ p   -> isStrictPattern p
 2186     SigPat _ p _    -> isStrictPattern p
 2187     BangPat{}       -> True
 2188     ListPat{}       -> True
 2189     TuplePat{}      -> True
 2190     SumPat{}        -> True
 2191     ConPat{}        -> True
 2192     LitPat{}        -> True
 2193     NPat{}          -> True
 2194     NPlusKPat{}     -> True
 2195     SplicePat{}     -> True
 2196     XPat ext        -> case ghcPass @p of
 2197 #if __GLASGOW_HASKELL__ < 811
 2198       GhcPs -> noExtCon ext
 2199 #endif
 2200       GhcRn
 2201         | HsPatExpanded _ p <- ext
 2202         -> isStrictPattern (L loc p)
 2203       GhcTc -> case ext of
 2204         ExpansionPat _ p -> isStrictPattern (L loc p)
 2205         CoPat {} -> panic "isStrictPattern: CoPat"
 2206 
 2207 {-
 2208 Note [ApplicativeDo and refutable patterns]
 2209 
 2210 Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
 2211 This means that sometimes an applicative block needs to be wrapped in 'join' simply because
 2212 of a refutable pattern, in order for the types to work out.
 2213 
 2214 -}
 2215 
 2216 hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
 2217 hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
 2218                                               , is_body_stmt = False}) =
 2219                                          not (isIrrefutableHsPat dflags pat)
 2220 hasRefutablePattern _ _ = False
 2221 
 2222 isLetStmt :: LStmt (GhcPass a) b -> Bool
 2223 isLetStmt (L _ LetStmt{}) = True
 2224 isLetStmt _ = False
 2225 
 2226 -- | Find a "good" place to insert a bind in an indivisible segment.
 2227 -- This is the only place where we use heuristics.  The current
 2228 -- heuristic is to peel off the first group of independent statements
 2229 -- and put the bind after those.
 2230 splitSegment
 2231   :: [(ExprLStmt GhcRn, FreeVars)]
 2232   -> ( [(ExprLStmt GhcRn, FreeVars)]
 2233      , [(ExprLStmt GhcRn, FreeVars)] )
 2234 splitSegment [one,two] = ([one],[two])
 2235   -- there is no choice when there are only two statements; this just saves
 2236   -- some work in a common case.
 2237 splitSegment stmts
 2238   | Just (lets,binds,rest) <- slurpIndependentStmts stmts
 2239   =  if not (null lets)
 2240        then (lets, binds++rest)
 2241        else (lets++binds, rest)
 2242   | otherwise
 2243   = case stmts of
 2244       (x:xs) -> ([x],xs)
 2245       _other -> (stmts,[])
 2246 
 2247 slurpIndependentStmts
 2248    :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
 2249    -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts
 2250             , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts
 2251             , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] )
 2252 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
 2253  where
 2254   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
 2255   -- in this group, then add it to the group. We have to be careful about
 2256   -- strict patterns though; splitSegments expects that if we return Just
 2257   -- then we have actually done some splitting. Otherwise it will go into
 2258   -- an infinite loop (#14163).
 2259   go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
 2260     | disjointNameSet bndrs fvs && not (isStrictPattern pat)
 2261     = go lets ((L loc (BindStmt xbs pat body), fvs) : indep)
 2262          bndrs' rest
 2263     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)
 2264   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
 2265   -- group, then move it to the beginning, so that it doesn't interfere with
 2266   -- grouping more BindStmts.
 2267   -- TODO: perhaps we shouldn't do this if there are any strict bindings,
 2268   -- because we might be moving evaluation earlier.
 2269   go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)
 2270     | disjointNameSet bndrs fvs
 2271     = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest
 2272   go _ []  _ _ = Nothing
 2273   go _ [_] _ _ = Nothing
 2274   go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
 2275 
 2276 -- | Build an ApplicativeStmt, and strip the "return" from the tail
 2277 -- if necessary.
 2278 --
 2279 -- For example, if we start with
 2280 --   do x <- E1; y <- E2; return (f x y)
 2281 -- then we get
 2282 --   do (E1[x] | E2[y]); f x y
 2283 --
 2284 -- the LastStmt in this case has the return removed, but we set the
 2285 -- flag on the LastStmt to indicate this, so that we can print out the
 2286 -- original statement correctly in error messages.  It is easier to do
 2287 -- it this way rather than try to ignore the return later in both the
 2288 -- typechecker and the desugarer (I tried it that way first!).
 2289 mkApplicativeStmt
 2290   :: HsDoFlavour
 2291   -> [ApplicativeArg GhcRn]             -- ^ The args
 2292   -> Bool                               -- ^ True <=> need a join
 2293   -> [ExprLStmt GhcRn]        -- ^ The body statements
 2294   -> RnM ([ExprLStmt GhcRn], FreeVars)
 2295 mkApplicativeStmt ctxt args need_join body_stmts
 2296   = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName
 2297        ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
 2298        ; (mb_join, fvs3) <-
 2299            if need_join then
 2300              do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
 2301                 ; return (Just join_op, fvs) }
 2302            else
 2303              return (Nothing, emptyNameSet)
 2304        ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
 2305                (zip (fmap_op : repeat ap_op) args)
 2306                mb_join
 2307        ; return ( applicative_stmt : body_stmts
 2308                 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 2309 
 2310 -- | Given the statements following an ApplicativeStmt, determine whether
 2311 -- we need a @join@ or not, and remove the @return@ if necessary.
 2312 needJoin :: MonadNames
 2313          -> [ExprLStmt GhcRn]
 2314          -> (Bool, [ExprLStmt GhcRn])
 2315 needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg
 2316 needJoin monad_names  [L loc (LastStmt _ e _ t)]
 2317  | Just (arg, wasDollar) <- isReturnApp monad_names e =
 2318        (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)])
 2319 needJoin _monad_names stmts = (True, stmts)
 2320 
 2321 -- | @(Just e, False)@, if the expression is @return e@
 2322 --   @(Just e, True)@ if the expression is @return $ e@,
 2323 --   otherwise @Nothing@.
 2324 isReturnApp :: MonadNames
 2325             -> LHsExpr GhcRn
 2326             -> Maybe (LHsExpr GhcRn, Bool)
 2327 isReturnApp monad_names (L _ (HsPar _ _ expr _)) = isReturnApp monad_names expr
 2328 isReturnApp monad_names (L _ e) = case e of
 2329   OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)
 2330   HsApp _ f arg  | is_return f               -> Just (arg, False)
 2331   _otherwise -> Nothing
 2332  where
 2333   is_var f (L _ (HsPar _ _ e _)) = is_var f e
 2334   is_var f (L _ (HsAppType _ e _)) = is_var f e
 2335   is_var f (L _ (HsVar _ (L _ r))) = f r
 2336        -- TODO: I don't know how to get this right for rebindable syntax
 2337   is_var _ _ = False
 2338 
 2339   is_return = is_var (\n -> n == return_name monad_names
 2340                          || n == pure_name monad_names)
 2341   is_dollar = is_var (`hasKey` dollarIdKey)
 2342 
 2343 {-
 2344 ************************************************************************
 2345 *                                                                      *
 2346 \subsubsection{Errors}
 2347 *                                                                      *
 2348 ************************************************************************
 2349 -}
 2350 
 2351 checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
 2352 -- We've seen an empty sequence of Stmts... is that ok?
 2353 checkEmptyStmts ctxt
 2354   = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
 2355 
 2356 okEmpty :: HsStmtContext a -> Bool
 2357 okEmpty (PatGuard {}) = True
 2358 okEmpty _             = False
 2359 
 2360 emptyErr :: HsStmtContext GhcRn -> TcRnMessage
 2361 emptyErr (ParStmtCtxt {})   = TcRnUnknownMessage $ mkPlainError noHints $
 2362   text "Empty statement group in parallel comprehension"
 2363 emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
 2364   text "Empty statement group preceding 'group' or 'then'"
 2365 emptyErr ctxt@(HsDoStmt _)  = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $
 2366   text "Empty" <+> pprStmtContext ctxt
 2367 emptyErr ctxt               = TcRnUnknownMessage $ mkPlainError noHints $
 2368   text "Empty" <+> pprStmtContext ctxt
 2369 
 2370 ----------------------
 2371 checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
 2372               -> LStmt GhcPs (LocatedA (body GhcPs))
 2373               -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
 2374 checkLastStmt ctxt lstmt@(L loc stmt)
 2375   = case ctxt of
 2376       HsDoStmt ListComp  -> check_comp
 2377       HsDoStmt MonadComp -> check_comp
 2378       HsDoStmt DoExpr{}  -> check_do
 2379       HsDoStmt MDoExpr{} -> check_do
 2380       ArrowExpr -> check_do
 2381       _         -> check_other
 2382   where
 2383     check_do    -- Expect BodyStmt, and change it to LastStmt
 2384       = case stmt of
 2385           BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
 2386           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
 2387                                              -- LastStmt directly (unlike the parser)
 2388           _                -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
 2389                                      (hang last_error 2 (ppr stmt))
 2390                                  ; return lstmt }
 2391     last_error = (text "The last statement in" <+> pprAStmtContext ctxt
 2392                   <+> text "must be an expression")
 2393 
 2394     check_comp  -- Expect LastStmt; this should be enforced by the parser!
 2395       = case stmt of
 2396           LastStmt {} -> return lstmt
 2397           _           -> pprPanic "checkLastStmt" (ppr lstmt)
 2398 
 2399     check_other -- Behave just as if this wasn't the last stmt
 2400       = do { checkStmt ctxt lstmt; return lstmt }
 2401 
 2402 -- Checking when a particular Stmt is ok
 2403 checkStmt :: HsStmtContext GhcRn
 2404           -> LStmt GhcPs (LocatedA (body GhcPs))
 2405           -> RnM ()
 2406 checkStmt ctxt (L _ stmt)
 2407   = do { dflags <- getDynFlags
 2408        ; case okStmt dflags ctxt stmt of
 2409            IsValid        -> return ()
 2410            NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }
 2411   where
 2412    msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
 2413              , text "in" <+> pprAStmtContext ctxt ]
 2414 
 2415 pprStmtCat :: Stmt (GhcPass a) body -> SDoc
 2416 pprStmtCat (TransStmt {})     = text "transform"
 2417 pprStmtCat (LastStmt {})      = text "return expression"
 2418 pprStmtCat (BodyStmt {})      = text "body"
 2419 pprStmtCat (BindStmt {})      = text "binding"
 2420 pprStmtCat (LetStmt {})       = text "let"
 2421 pprStmtCat (RecStmt {})       = text "rec"
 2422 pprStmtCat (ParStmt {})       = text "parallel"
 2423 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
 2424 
 2425 ------------
 2426 emptyInvalid :: Validity  -- Payload is the empty document
 2427 emptyInvalid = NotValid Outputable.empty
 2428 
 2429 okStmt, okDoStmt, okCompStmt, okParStmt
 2430    :: DynFlags -> HsStmtContext GhcRn
 2431    -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
 2432 -- Return Nothing if OK, (Just extra) if not ok
 2433 -- The "extra" is an SDoc that is appended to a generic error message
 2434 
 2435 okStmt dflags ctxt stmt
 2436   = case ctxt of
 2437       PatGuard {}        -> okPatGuardStmt stmt
 2438       ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt
 2439       HsDoStmt flavour   -> okDoFlavourStmt dflags flavour ctxt stmt
 2440       ArrowExpr          -> okDoStmt   dflags ctxt stmt
 2441       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
 2442 
 2443 okDoFlavourStmt
 2444   :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
 2445   -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
 2446 okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
 2447       DoExpr{}     -> okDoStmt   dflags ctxt stmt
 2448       MDoExpr{}    -> okDoStmt   dflags ctxt stmt
 2449       GhciStmtCtxt -> okDoStmt   dflags ctxt stmt
 2450       ListComp     -> okCompStmt dflags ctxt stmt
 2451       MonadComp    -> okCompStmt dflags ctxt stmt
 2452 
 2453 -------------
 2454 okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
 2455 okPatGuardStmt stmt
 2456   = case stmt of
 2457       BodyStmt {} -> IsValid
 2458       BindStmt {} -> IsValid
 2459       LetStmt {}  -> IsValid
 2460       _           -> emptyInvalid
 2461 
 2462 -------------
 2463 okParStmt dflags ctxt stmt
 2464   = case stmt of
 2465       LetStmt _ (HsIPBinds {}) -> emptyInvalid
 2466       _                        -> okStmt dflags ctxt stmt
 2467 
 2468 ----------------
 2469 okDoStmt dflags ctxt stmt
 2470   = case stmt of
 2471        RecStmt {}
 2472          | LangExt.RecursiveDo `xopt` dflags -> IsValid
 2473          | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
 2474          | otherwise         -> NotValid (text "Use RecursiveDo")
 2475        BindStmt {} -> IsValid
 2476        LetStmt {}  -> IsValid
 2477        BodyStmt {} -> IsValid
 2478        _           -> emptyInvalid
 2479 
 2480 ----------------
 2481 okCompStmt dflags _ stmt
 2482   = case stmt of
 2483        BindStmt {} -> IsValid
 2484        LetStmt {}  -> IsValid
 2485        BodyStmt {} -> IsValid
 2486        ParStmt {}
 2487          | LangExt.ParallelListComp `xopt` dflags -> IsValid
 2488          | otherwise -> NotValid (text "Use ParallelListComp")
 2489        TransStmt {}
 2490          | LangExt.TransformListComp `xopt` dflags -> IsValid
 2491          | otherwise -> NotValid (text "Use TransformListComp")
 2492        RecStmt {}  -> emptyInvalid
 2493        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
 2494        ApplicativeStmt {} -> emptyInvalid
 2495 
 2496 ---------
 2497 checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
 2498 checkTupleSection args
 2499   = do  { tuple_section <- xoptM LangExt.TupleSections
 2500         ; checkErr (all tupArgPresent args || tuple_section) msg }
 2501   where
 2502     msg :: TcRnMessage
 2503     msg = TcRnUnknownMessage $ mkPlainError noHints $
 2504       text "Illegal tuple section: use TupleSections"
 2505 
 2506 ---------
 2507 sectionErr :: HsExpr GhcPs -> TcRnMessage
 2508 sectionErr expr
 2509   = TcRnUnknownMessage $ mkPlainError noHints $
 2510     hang (text "A section must be enclosed in parentheses")
 2511        2 (text "thus:" <+> (parens (ppr expr)))
 2512 
 2513 badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage
 2514 badIpBinds what binds
 2515   = TcRnUnknownMessage $ mkPlainError noHints $
 2516     hang (text "Implicit-parameter bindings illegal in" <+> what)
 2517          2 (ppr binds)
 2518 
 2519 ---------
 2520 
 2521 monadFailOp :: LPat GhcPs
 2522             -> HsStmtContext GhcRn
 2523             -> RnM (FailOperator GhcRn, FreeVars)
 2524 monadFailOp pat ctxt = do
 2525     dflags <- getDynFlags
 2526         -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
 2527         -- we should not need to fail.
 2528     if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
 2529 
 2530         -- For non-monadic contexts (e.g. guard patterns, list
 2531         -- comprehensions, etc.) we should not need to fail, or failure is handled in
 2532         -- a different way. See Note [Failing pattern matches in Stmts].
 2533        | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
 2534 
 2535        | otherwise -> getMonadFailOp ctxt
 2536 
 2537 {-
 2538 Note [Monad fail : Rebindable syntax, overloaded strings]
 2539 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 2540 
 2541 Given the code
 2542   foo x = do { Just y <- x; return y }
 2543 
 2544 we expect it to desugar as
 2545   foo x = x >>= \r -> case r of
 2546                         Just y  -> return y
 2547                         Nothing -> fail "Pattern match error"
 2548 
 2549 But with RebindableSyntax and OverloadedStrings, we really want
 2550 it to desugar thus:
 2551   foo x = x >>= \r -> case r of
 2552                         Just y  -> return y
 2553                         Nothing -> fail (fromString "Patterm match error")
 2554 
 2555 So, in this case, we synthesize the function
 2556   \x -> fail (fromString x)
 2557 
 2558 (rather than plain 'fail') for the 'fail' operation. This is done in
 2559 'getMonadFailOp'.
 2560 
 2561 Similarly with QualifiedDo and OverloadedStrings, we also want to desugar
 2562 using fromString:
 2563 
 2564   foo x = M.do { Just y <- x; return y }
 2565 
 2566   ===>
 2567 
 2568   foo x = x M.>>= \r -> case r of
 2569                         Just y  -> return y
 2570                         Nothing -> M.fail (fromString "Pattern match error")
 2571 
 2572 -}
 2573 getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
 2574 getMonadFailOp ctxt
 2575  = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
 2576       ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
 2577       ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
 2578       ; return (Just fail, fvs)
 2579       }
 2580   where
 2581     isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)
 2582 
 2583     reallyGetMonadFailOp rebindableSyntax overloadedStrings
 2584       | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
 2585         (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
 2586         (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
 2587         let arg_lit = mkVarOcc "arg"
 2588         arg_name <- newSysName arg_lit
 2589         let arg_syn_expr = nlHsVar arg_name
 2590             body :: LHsExpr GhcRn =
 2591               nlHsApp (noLocA failExpr)
 2592                       (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
 2593         let failAfterFromStringExpr :: HsExpr GhcRn =
 2594               unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
 2595         let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
 2596               mkSyntaxExpr failAfterFromStringExpr
 2597         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
 2598       | otherwise = lookupQualifiedDo ctxt failMName
 2599 
 2600 
 2601 {- *********************************************************************
 2602 *                                                                      *
 2603               Generating code for HsExpanded
 2604       See Note [Handling overloaded and rebindable constructs]
 2605 *                                                                      *
 2606 ********************************************************************* -}
 2607 
 2608 -- | Build a 'HsExpansion' out of an extension constructor,
 2609 --   and the two components of the expansion: original and
 2610 --   desugared expressions.
 2611 mkExpandedExpr
 2612   :: HsExpr GhcRn           -- ^ source expression
 2613   -> HsExpr GhcRn           -- ^ expanded expression
 2614   -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
 2615 mkExpandedExpr a b = XExpr (HsExpanded a b)
 2616 
 2617 -----------------------------------------
 2618 -- Bits and pieces for RecordDotSyntax.
 2619 --
 2620 -- See Note [Overview of record dot syntax] in GHC.Hs.Expr.
 2621 
 2622 -- mkGetField arg field calcuates a get_field @field arg expression.
 2623 -- e.g. z.x = mkGetField z x = get_field @x z
 2624 mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
 2625 mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
 2626 
 2627 -- mkSetField a field b calculates a set_field @field expression.
 2628 -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").
 2629 mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
 2630 mkSetField set_field a (L _ field) b =
 2631   genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b
 2632 
 2633 mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
 2634 mkGet get_field l@(r : _) (L _ field) =
 2635   wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
 2636 mkGet _ [] _ = panic "mkGet : The impossible has happened!"
 2637 
 2638 mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
 2639 mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
 2640 
 2641 -- mkProjection fields calculates a projection.
 2642 -- e.g. .x = mkProjection [x] = getField @"x"
 2643 --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
 2644 mkProjection :: Name -> Name -> [LocatedAn NoEpAnns FieldLabelString] -> HsExpr GhcRn
 2645 mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields
 2646   where
 2647     f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
 2648     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
 2649 
 2650     proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
 2651     proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
 2652 mkProjection _ _ [] = panic "mkProjection: The impossible happened"
 2653 
 2654 -- mkProjUpdateSetField calculates functions representing dot notation record updates.
 2655 -- e.g. Suppose an update like foo.bar = 1.
 2656 --      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1).
 2657 mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
 2658 mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
 2659   = let {
 2660       ; flds = map (fmap (unLoc . dfoLabel)) flds'
 2661       ; final = last flds  -- quux
 2662       ; fields = init flds   -- [foo, bar, baz]
 2663       ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.
 2664           -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
 2665       ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
 2666           -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
 2667       }
 2668     in (\a -> foldl' (mkSet set_field) arg (zips a))
 2669           -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
 2670 
 2671 mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn
 2672 mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates
 2673   where
 2674     fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
 2675     fieldUpdate acc lpu =  unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)
 2676 
 2677 rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
 2678 rnHsUpdProjs us = do
 2679   (u, fvs) <- unzip <$> mapM rnRecUpdProj us
 2680   pure (u, plusFVs fvs)
 2681   where
 2682     rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
 2683     rnRecUpdProj (L l (HsFieldBind _ fs arg pun))
 2684       = do { (arg, fv) <- rnLExpr arg
 2685            ; return $
 2686                (L l (HsFieldBind {
 2687                          hfbAnn = noAnn
 2688                        , hfbLHS = fmap rnFieldLabelStrings fs
 2689                        , hfbRHS = arg
 2690                        , hfbPun = pun}), fv ) }