{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[RnExpr]{Renaming of expressions}

Basically dependency analysis.

Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
general, all of these functions return a renamed thing, and a set of
free variables.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module RnExpr (
        rnLExpr, rnExpr, rnStmts
   ) where

#include "HsVersions.h"

import GhcPrelude

import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Hs
import TcEnv            ( isBrackStage )
import TcRnMonad
import Module           ( getModule )
import RnEnv
import RnFixity
import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
                        , bindLocalNames
                        , mapMaybeFvRn, mapFvRn
                        , warnUnusedLocalBinds, typeAppErr
                        , checkUnusedRecordWildcard )
import RnUnbound        ( reportUnboundName )
import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes
import RnPat
import DynFlags
import PrelNames

import BasicTypes
import Name
import NameSet
import RdrName
import UniqSet
import Data.List
import Util
import ListSetOps       ( removeDups )
import ErrUtils
import Outputable
import SrcLoc
import FastString
import Control.Monad
import TysWiredIn       ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt

import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE

import Unique           ( mkVarOccUnique )

{-
************************************************************************
*                                                                      *
\subsubsection{Expressions}
*                                                                      *
************************************************************************
-}

rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs [LHsExpr GhcPs]
ls = [LHsExpr GhcPs] -> FreeVars -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs' [LHsExpr GhcPs]
ls FreeVars
forall a. UniqSet a
emptyUniqSet
 where
  rnExprs' :: [LHsExpr GhcPs] -> FreeVars -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs' [] FreeVars
acc = ([LHsExpr GhcRn], FreeVars) -> RnM ([LHsExpr GhcRn], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
acc)
  rnExprs' (LHsExpr GhcPs
expr:[LHsExpr GhcPs]
exprs) FreeVars
acc =
   do { (LHsExpr GhcRn
expr', FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        -- Now we do a "seq" on the free vars because typically it's small
        -- or empty, especially in very long lists of constants
      ; let  acc' :: FreeVars
acc' = FreeVars
acc FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr
      ; ([LHsExpr GhcRn]
exprs', FreeVars
fvExprs) <- FreeVars
acc' FreeVars
-> RnM ([LHsExpr GhcRn], FreeVars)
-> RnM ([LHsExpr GhcRn], FreeVars)
`seq` [LHsExpr GhcPs] -> FreeVars -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs' [LHsExpr GhcPs]
exprs FreeVars
acc'
      ; ([LHsExpr GhcRn], FreeVars) -> RnM ([LHsExpr GhcRn], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn
expr'LHsExpr GhcRn -> [LHsExpr GhcRn] -> [LHsExpr GhcRn]
forall a. a -> [a] -> [a]
:[LHsExpr GhcRn]
exprs', FreeVars
fvExprs) }

-- Variables. We look up the variable and return the resulting name.

rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr = (SrcSpanLess (LHsExpr GhcPs)
 -> TcM (SrcSpanLess (LHsExpr GhcRn), FreeVars))
-> LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LHsExpr GhcPs)
-> TcM (SrcSpanLess (LHsExpr GhcRn), FreeVars)
HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr

rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)

finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
-- Separated from rnExpr because it's also used
-- when renaming infix expressions
finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (L SrcSpan
l Name
name)
 = do { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
      ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
        Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkThLocalName Name
name
      ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l Name
name), Name -> FreeVars
unitFV Name
name) }

rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
v
 = do { if RdrName -> Bool
isUnqual RdrName
v
        then -- Treat this as a "hole"
             -- Do not fail right now; instead, return HsUnboundVar
             -- and let the type checker report the error
             do { let occ :: OccName
occ = RdrName -> OccName
rdrNameOcc RdrName
v
                ; UnboundVar
uv <- if OccName -> Bool
startsWithUnderscore OccName
occ
                        then UnboundVar -> IOEnv (Env TcGblEnv TcLclEnv) UnboundVar
forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> UnboundVar
TrueExprHole OccName
occ)
                        else OccName -> GlobalRdrEnv -> UnboundVar
OutOfScope OccName
occ (GlobalRdrEnv -> UnboundVar)
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnboundVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
                ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcRn -> UnboundVar -> HsExpr GhcRn
forall p. XUnboundVar p -> UnboundVar -> HsExpr p
HsUnboundVar XUnboundVar GhcRn
NoExtField
noExtField UnboundVar
uv, FreeVars
emptyFVs) }

        else -- Fail immediately (qualified name)
             do { Name
n <- RdrName -> RnM Name
reportUnboundName RdrName
v
                ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (Located Name)
n), FreeVars
emptyFVs) } }

rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (HsVar XVar GhcPs
_ (L SrcSpan
l IdP GhcPs
v))
  = do { Bool
opt_DuplicateRecordFields <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DuplicateRecordFields
       ; Maybe (Either Name [Name])
mb_name <- Bool -> RdrName -> RnM (Maybe (Either Name [Name]))
lookupOccRn_overloaded Bool
opt_DuplicateRecordFields RdrName
IdP GhcPs
v
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; case Maybe (Either Name [Name])
mb_name of {
           Maybe (Either Name [Name])
Nothing -> RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
IdP GhcPs
v ;
           Just (Left Name
name)
              | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
                                       -- Note [Empty lists] in GHC.Hs.Expr
              , Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedLists DynFlags
dflags
              -> HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (XExplicitList GhcPs
-> Maybe (SyntaxExpr GhcPs) -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
NoExtField
noExtField Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing [])

              | Bool
otherwise
              -> Located Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l Name
name) ;
            Just (Right [Name
s]) ->
              (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld XRecFld GhcRn
NoExtField
noExtField (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
s (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
IdP GhcPs
v) ), Name -> FreeVars
unitFV Name
s) ;
           Just (Right fs :: [Name]
fs@(Name
_:Name
_:[Name]
_)) ->
              (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld XRecFld GhcRn
NoExtField
noExtField (XAmbiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XAmbiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Ambiguous XAmbiguous GhcRn
NoExtField
noExtField (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
l RdrName
IdP GhcPs
v))
                     , [Name] -> FreeVars
mkFVs [Name]
fs);
           Just (Right [])         -> String -> RnM (HsExpr GhcRn, FreeVars)
forall a. String -> a
panic String
"runExpr/HsVar" } }

rnExpr (HsIPVar XIPVar GhcPs
x HsIPName
v)
  = (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIPVar GhcRn -> HsIPName -> HsExpr GhcRn
forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar XIPVar GhcPs
XIPVar GhcRn
x HsIPName
v, FreeVars
emptyFVs)

rnExpr (HsUnboundVar XUnboundVar GhcPs
x UnboundVar
v)
  = (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcRn -> UnboundVar -> HsExpr GhcRn
forall p. XUnboundVar p -> UnboundVar -> HsExpr p
HsUnboundVar XUnboundVar GhcPs
XUnboundVar GhcRn
x UnboundVar
v, FreeVars
emptyFVs)

rnExpr (HsOverLabel XOverLabel GhcPs
x Maybe (IdP GhcPs)
_ FastString
v)
  = do { Bool
rebindable_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RebindableSyntax
       ; if Bool
rebindable_on
         then do { Name
fromLabel <- RdrName -> RnM Name
lookupOccRn (FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"fromLabel"))
                 ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLabel GhcRn -> Maybe (IdP GhcRn) -> FastString -> HsExpr GhcRn
forall p. XOverLabel p -> Maybe (IdP p) -> FastString -> HsExpr p
HsOverLabel XOverLabel GhcPs
XOverLabel GhcRn
x (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
fromLabel) FastString
v, Name -> FreeVars
unitFV Name
fromLabel) }
         else (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLabel GhcRn -> Maybe (IdP GhcRn) -> FastString -> HsExpr GhcRn
forall p. XOverLabel p -> Maybe (IdP p) -> FastString -> HsExpr p
HsOverLabel XOverLabel GhcPs
XOverLabel GhcRn
x Maybe (IdP GhcRn)
forall a. Maybe a
Nothing FastString
v, FreeVars
emptyFVs) }

rnExpr (HsLit XLitE GhcPs
x lit :: HsLit GhcPs
lit@(HsString XHsString GhcPs
src FastString
s))
  = do { Bool
opt_OverloadedStrings <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
       ; if Bool
opt_OverloadedStrings then
            HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XLitE GhcPs
XOverLitE GhcPs
x (SourceText -> FastString -> HsOverLit GhcPs
mkHsIsString SourceText
XHsString GhcPs
src FastString
s))
         else do {
            ; HsLit GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall p. HsLit p -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnLit HsLit GhcPs
lit
            ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
XLitE GhcRn
x (HsLit GhcPs -> HsLit GhcRn
forall a b. ConvertIdX a b => HsLit a -> HsLit b
convertLit HsLit GhcPs
lit), FreeVars
emptyFVs) } }

rnExpr (HsLit XLitE GhcPs
x HsLit GhcPs
lit)
  = do { HsLit GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall p. HsLit p -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnLit HsLit GhcPs
lit
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
XLitE GhcRn
x(HsLit GhcPs -> HsLit GhcRn
forall a b. ConvertIdX a b => HsLit a -> HsLit b
convertLit HsLit GhcPs
lit), FreeVars
emptyFVs) }

rnExpr (HsOverLit XOverLitE GhcPs
x HsOverLit GhcPs
lit)
  = do { ((HsOverLit GhcRn
lit', Maybe (HsExpr GhcRn)
mb_neg), FreeVars
fvs) <- HsOverLit GhcPs
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall t.
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit GhcPs
lit -- See Note [Negative zero]
       ; case Maybe (HsExpr GhcRn)
mb_neg of
              Maybe (HsExpr GhcRn)
Nothing -> (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
XOverLitE GhcRn
x HsOverLit GhcRn
lit', FreeVars
fvs)
              Just HsExpr GhcRn
neg -> (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
XOverLitE GhcPs
x (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
neg) (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
XOverLitE GhcRn
x HsOverLit GhcRn
lit'))
                                 , FreeVars
fvs ) }

rnExpr (HsApp XApp GhcPs
x LHsExpr GhcPs
fun LHsExpr GhcPs
arg)
  = do { (LHsExpr GhcRn
fun',FreeVars
fvFun) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
fun
       ; (LHsExpr GhcRn
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
arg
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
XApp GhcRn
x LHsExpr GhcRn
fun' LHsExpr GhcRn
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }

rnExpr (HsAppType XAppTypeE GhcPs
x LHsExpr GhcPs
fun LHsWcType (NoGhcTc GhcPs)
arg)
  = do { Bool
type_app <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
type_app (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs -> MsgDoc
typeAppErr String
"type" (LHsType GhcPs -> MsgDoc) -> LHsType GhcPs -> MsgDoc
forall a b. (a -> b) -> a -> b
$ HsWildCardBndrs GhcPs (LHsType GhcPs) -> LHsType GhcPs
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsWcType (NoGhcTc GhcPs)
HsWildCardBndrs GhcPs (LHsType GhcPs)
arg
       ; (LHsExpr GhcRn
fun',FreeVars
fvFun) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
fun
       ; (LHsWcType GhcRn
arg',FreeVars
fvArg) <- HsDocContext
-> HsWildCardBndrs GhcPs (LHsType GhcPs)
-> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
HsTypeCtx LHsWcType (NoGhcTc GhcPs)
HsWildCardBndrs GhcPs (LHsType GhcPs)
arg
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppTypeE GhcRn
-> LHsExpr GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
XAppTypeE GhcRn
x LHsExpr GhcRn
fun' LHsWcType (NoGhcTc GhcRn)
LHsWcType GhcRn
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }

rnExpr (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
e1 LHsExpr GhcPs
op LHsExpr GhcPs
e2)
  = do  { (LHsExpr GhcRn
e1', FreeVars
fv_e1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e1
        ; (LHsExpr GhcRn
e2', FreeVars
fv_e2) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e2
        ; (LHsExpr GhcRn
op', FreeVars
fv_op) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
op

        -- Deal with fixity
        -- When renaming code synthesised from "deriving" declarations
        -- we used to avoid fixity stuff, but we can't easily tell any
        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
        -- should prevent bad things happening.
        ; Fixity
fixity <- case LHsExpr GhcRn
op' of
              L SrcSpan
_ (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
n)) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
IdP GhcRn
n
              L SrcSpan
_ (HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f)    -> AmbiguousFieldOcc GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFieldFixityRn AmbiguousFieldOcc GhcRn
f
              LHsExpr GhcRn
_ -> Fixity -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
NoSourceText Int
minPrecedence FixityDirection
InfixL)
                   -- c.f. lookupFixity for unbound

        ; HsExpr GhcRn
final_e <- LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn LHsExpr GhcRn
e1' LHsExpr GhcRn
op' Fixity
fixity LHsExpr GhcRn
e2'
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
final_e, FreeVars
fv_e1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_op FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_e2) }

rnExpr (NegApp XNegApp GhcPs
_ LHsExpr GhcPs
e SyntaxExpr GhcPs
_)
  = do { (LHsExpr GhcRn
e', FreeVars
fv_e)         <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e
       ; (SyntaxExpr GhcRn
neg_name, FreeVars
fv_neg) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
negateName
       ; HsExpr GhcRn
final_e            <- LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> SyntaxExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))
mkNegAppRn LHsExpr GhcRn
e' SyntaxExpr GhcRn
neg_name
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
final_e, FreeVars
fv_e FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_neg) }

------------------------------------------
-- Template Haskell extensions
rnExpr e :: HsExpr GhcPs
e@(HsBracket XBracket GhcPs
_ HsBracket GhcPs
br_body) = HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnBracket HsExpr GhcPs
e HsBracket GhcPs
br_body

rnExpr (HsSpliceE XSpliceE GhcPs
_ HsSplice GhcPs
splice) = HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSpliceExpr HsSplice GhcPs
splice

---------------------------------------------
--      Sections
-- See Note [Parsing sections] in Parser.y
rnExpr (HsPar XPar GhcPs
x (L SrcSpan
loc (section :: HsExpr GhcPs
section@(SectionL {}))))
  = do  { (HsExpr GhcRn
section', FreeVars
fvs) <- HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
XPar GhcRn
x (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcRn
section'), FreeVars
fvs) }

rnExpr (HsPar XPar GhcPs
x (L SrcSpan
loc (section :: HsExpr GhcPs
section@(SectionR {}))))
  = do  { (HsExpr GhcRn
section', FreeVars
fvs) <- HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
XPar GhcRn
x (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcRn
section'), FreeVars
fvs) }

rnExpr (HsPar XPar GhcPs
x LHsExpr GhcPs
e)
  = do  { (LHsExpr GhcRn
e', FreeVars
fvs_e) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
XPar GhcRn
x LHsExpr GhcRn
e', FreeVars
fvs_e) }

rnExpr expr :: HsExpr GhcPs
expr@(SectionL {})
  = do  { MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> MsgDoc
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }
rnExpr expr :: HsExpr GhcPs
expr@(SectionR {})
  = do  { MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> MsgDoc
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }

---------------------------------------------
rnExpr (HsCoreAnn XCoreAnn GhcPs
x SourceText
src StringLiteral
ann LHsExpr GhcPs
expr)
  = do { (LHsExpr GhcRn
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCoreAnn GhcRn
-> SourceText -> StringLiteral -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XCoreAnn p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsCoreAnn XCoreAnn GhcPs
XCoreAnn GhcRn
x SourceText
src StringLiteral
ann LHsExpr GhcRn
expr', FreeVars
fvs_expr) }

rnExpr (HsSCC XSCC GhcPs
x SourceText
src StringLiteral
lbl LHsExpr GhcPs
expr)
  = do { (LHsExpr GhcRn
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSCC GhcRn
-> SourceText -> StringLiteral -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XSCC p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsSCC XSCC GhcPs
XSCC GhcRn
x SourceText
src StringLiteral
lbl LHsExpr GhcRn
expr', FreeVars
fvs_expr) }
rnExpr (HsTickPragma XTickPragma GhcPs
x SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo LHsExpr GhcPs
expr)
  = do { (LHsExpr GhcRn
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTickPragma GhcRn
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr GhcRn
-> HsExpr GhcRn
forall p.
XTickPragma p
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr p
-> HsExpr p
HsTickPragma XTickPragma GhcPs
XTickPragma GhcRn
x SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo LHsExpr GhcRn
expr', FreeVars
fvs_expr) }

rnExpr (HsLam XLam GhcPs
x MatchGroup GhcPs (LHsExpr GhcPs)
matches)
  = do { (MatchGroup GhcRn (LHsExpr GhcRn)
matches', FreeVars
fvMatch) <- HsMatchContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> RnM (MatchGroup GhcRn (LHsExpr GhcRn), FreeVars)
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLam GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) -> HsExpr GhcRn
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcPs
XLam GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches', FreeVars
fvMatch) }

rnExpr (HsLamCase XLamCase GhcPs
x MatchGroup GhcPs (LHsExpr GhcPs)
matches)
  = do { (MatchGroup GhcRn (LHsExpr GhcRn)
matches', FreeVars
fvs_ms) <- HsMatchContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> RnM (MatchGroup GhcRn (LHsExpr GhcRn), FreeVars)
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContext Name
forall id. HsMatchContext id
CaseAlt LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLamCase GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) -> HsExpr GhcRn
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcPs
XLamCase GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches', FreeVars
fvs_ms) }

rnExpr (HsCase XCase GhcPs
x LHsExpr GhcPs
expr MatchGroup GhcPs (LHsExpr GhcPs)
matches)
  = do { (LHsExpr GhcRn
new_expr, FreeVars
e_fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (MatchGroup GhcRn (LHsExpr GhcRn)
new_matches, FreeVars
ms_fvs) <- HsMatchContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> RnM (MatchGroup GhcRn (LHsExpr GhcRn), FreeVars)
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContext Name
forall id. HsMatchContext id
CaseAlt LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcRn
-> LHsExpr GhcRn
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> HsExpr GhcRn
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcPs
XCase GhcRn
x LHsExpr GhcRn
new_expr MatchGroup GhcRn (LHsExpr GhcRn)
new_matches, FreeVars
e_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
ms_fvs) }

rnExpr (HsLet XLet GhcPs
x (L SrcSpan
l HsLocalBinds GhcPs
binds) LHsExpr GhcPs
expr)
  = HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn -> FreeVars -> RnM (HsExpr GhcRn, FreeVars))
 -> RnM (HsExpr GhcRn, FreeVars))
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
_ -> do
      { (LHsExpr GhcRn
expr',FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
      ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcRn -> LHsLocalBinds GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcPs
XLet GhcRn
x (SrcSpan -> HsLocalBinds GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcRn
binds') LHsExpr GhcRn
expr', FreeVars
fvExpr) }

rnExpr (HsDo XDo GhcPs
x HsStmtContext Name
do_or_lc (L SrcSpan
l [ExprLStmt GhcPs]
stmts))
  = do  { (([LStmt GhcRn (LHsExpr GhcRn)]
stmts', ()
_), FreeVars
fvs) <-
           HsStmtContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> (HsStmtContext Name
    -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
    -> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars))
-> [ExprLStmt GhcPs]
-> ([Name] -> RnM ((), FreeVars))
-> RnM (([LStmt GhcRn (LHsExpr GhcRn)], ()), FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> (HsStmtContext Name
    -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
    -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext Name
do_or_lc LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr
             HsStmtContext Name
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
postProcessStmtsForApplicativeDo [ExprLStmt GhcPs]
stmts
             (\ [Name]
_ -> ((), FreeVars) -> RnM ((), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XDo GhcRn
-> HsStmtContext Name
-> Located [LStmt GhcRn (LHsExpr GhcRn)]
-> HsExpr GhcRn
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo XDo GhcPs
XDo GhcRn
x HsStmtContext Name
do_or_lc (SrcSpan
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> Located [LStmt GhcRn (LHsExpr GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcRn (LHsExpr GhcRn)]
stmts'), FreeVars
fvs ) }

rnExpr (ExplicitList XExplicitList GhcPs
x Maybe (SyntaxExpr GhcPs)
_  [LHsExpr GhcPs]
exps)
  = do  { Bool
opt_OverloadedLists <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
        ; ([LHsExpr GhcRn]
exps', FreeVars
fvs) <- [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs [LHsExpr GhcPs]
exps
        ; if Bool
opt_OverloadedLists
           then do {
            ; (SyntaxExpr GhcRn
from_list_n_name, FreeVars
fvs') <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
fromListNName
            ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitList GhcRn
-> Maybe (SyntaxExpr GhcRn) -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
XExplicitList GhcRn
x (SyntaxExpr GhcRn -> Maybe (SyntaxExpr GhcRn)
forall a. a -> Maybe a
Just SyntaxExpr GhcRn
from_list_n_name) [LHsExpr GhcRn]
exps'
                     , FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs') }
           else
            (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return  (XExplicitList GhcRn
-> Maybe (SyntaxExpr GhcRn) -> [LHsExpr GhcRn] -> HsExpr GhcRn
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
XExplicitList GhcRn
x Maybe (SyntaxExpr GhcRn)
forall a. Maybe a
Nothing [LHsExpr GhcRn]
exps', FreeVars
fvs) }

rnExpr (ExplicitTuple XExplicitTuple GhcPs
x [LHsTupArg GhcPs]
tup_args Boxity
boxity)
  = do { [LHsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [LHsTupArg GhcPs]
tup_args
       ; Int -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupSize ([LHsTupArg GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTupArg GhcPs]
tup_args)
       ; ([GenLocated SrcSpan (HsTupArg GhcRn)]
tup_args', [FreeVars]
fvs) <- (LHsTupArg GhcPs
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpan (HsTupArg GhcRn), FreeVars))
-> [LHsTupArg GhcPs]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated SrcSpan (HsTupArg GhcRn)], [FreeVars])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LHsTupArg GhcPs
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpan (HsTupArg GhcRn), FreeVars)
forall l.
GenLocated l (HsTupArg GhcPs)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcRn), FreeVars)
rnTupArg [LHsTupArg GhcPs]
tup_args
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitTuple GhcRn
-> [GenLocated SrcSpan (HsTupArg GhcRn)] -> Boxity -> HsExpr GhcRn
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
XExplicitTuple GhcRn
x [GenLocated SrcSpan (HsTupArg GhcRn)]
tup_args' Boxity
boxity, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvs) }
  where
    rnTupArg :: GenLocated l (HsTupArg GhcPs)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcRn), FreeVars)
rnTupArg (L l
l (Present XPresent GhcPs
x LHsExpr GhcPs
e)) = do { (LHsExpr GhcRn
e',FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
e
                                      ; (GenLocated l (HsTupArg GhcRn), FreeVars)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcRn -> GenLocated l (HsTupArg GhcRn)
forall l e. l -> e -> GenLocated l e
L l
l (XPresent GhcRn -> LHsExpr GhcRn -> HsTupArg GhcRn
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
XPresent GhcRn
x LHsExpr GhcRn
e'), FreeVars
fvs) }
    rnTupArg (L l
l (Missing XMissing GhcPs
_)) = (GenLocated l (HsTupArg GhcRn), FreeVars)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcRn -> GenLocated l (HsTupArg GhcRn)
forall l e. l -> e -> GenLocated l e
L l
l (XMissing GhcRn -> HsTupArg GhcRn
forall id. XMissing id -> HsTupArg id
Missing XMissing GhcRn
NoExtField
noExtField)
                                        , FreeVars
emptyFVs)
    rnTupArg (L l
_ (XTupArg XXTupArg GhcPs
nec)) = NoExtCon
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcRn), FreeVars)
forall a. NoExtCon -> a
noExtCon XXTupArg GhcPs
NoExtCon
nec

rnExpr (ExplicitSum XExplicitSum GhcPs
x Int
alt Int
arity LHsExpr GhcPs
expr)
  = do { (LHsExpr GhcRn
expr', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitSum GhcRn -> Int -> Int -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcPs
XExplicitSum GhcRn
x Int
alt Int
arity LHsExpr GhcRn
expr', FreeVars
fvs) }

rnExpr (RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = GenLocated SrcSpan (IdP GhcPs)
con_id
                  , rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = rec_binds :: HsRecordBinds GhcPs
rec_binds@(HsRecFields { rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
dd }) })
  = do { con_lname :: Located Name
con_lname@(L SrcSpan
_ Name
con_name) <- Located RdrName -> RnM (Located Name)
lookupLocatedOccRn Located RdrName
GenLocated SrcSpan (IdP GhcPs)
con_id
       ; ([LHsRecField GhcRn (LHsExpr GhcPs)]
flds, FreeVars
fvs)   <- HsRecFieldContext
-> (SrcSpan -> RdrName -> SrcSpanLess (LHsExpr GhcPs))
-> HsRecordBinds GhcPs
-> RnM ([LHsRecField GhcRn (LHsExpr GhcPs)], FreeVars)
forall arg.
HasSrcSpan arg =>
HsRecFieldContext
-> (SrcSpan -> RdrName -> SrcSpanLess arg)
-> HsRecFields GhcPs arg
-> RnM ([LHsRecField GhcRn arg], FreeVars)
rnHsRecFields (Name -> HsRecFieldContext
HsRecFieldCon Name
con_name) SrcSpan -> RdrName -> SrcSpanLess (LHsExpr GhcPs)
forall p. (XVar p ~ NoExtField) => SrcSpan -> IdP p -> HsExpr p
mk_hs_var HsRecordBinds GhcPs
rec_binds
       ; ([GenLocated SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn))]
flds', [FreeVars]
fvss) <- (LHsRecField GhcRn (LHsExpr GhcPs)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn)),
       FreeVars))
-> [LHsRecField GhcRn (LHsExpr GhcPs)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn))],
      [FreeVars])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LHsRecField GhcRn (LHsExpr GhcPs)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn)),
      FreeVars)
forall l id.
GenLocated l (HsRecField' id (LHsExpr GhcPs))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated l (HsRecField' id (LHsExpr GhcRn)), FreeVars)
rn_field [LHsRecField GhcRn (LHsExpr GhcPs)]
flds
       ; let rec_binds' :: HsRecFields GhcRn (LHsExpr GhcRn)
rec_binds' = HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields { rec_flds :: [GenLocated SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn))]
rec_flds = [GenLocated SrcSpan (HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn))]
flds', rec_dotdot :: Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
dd }
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcRn
rcon_ext = XRecordCon GhcRn
NoExtField
noExtField
                           , rcon_con_name :: Located (IdP GhcRn)
rcon_con_name = Located Name
Located (IdP GhcRn)
con_lname, rcon_flds :: HsRecFields GhcRn (LHsExpr GhcRn)
rcon_flds = HsRecFields GhcRn (LHsExpr GhcRn)
rec_binds' }
                , FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvss FreeVars -> Name -> FreeVars
`addOneFV` Name
con_name) }
  where
    mk_hs_var :: SrcSpan -> IdP p -> HsExpr p
mk_hs_var SrcSpan
l IdP p
n = XVar p -> Located (IdP p) -> HsExpr p
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar p
NoExtField
noExtField (SrcSpan -> IdP p -> Located (IdP p)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l IdP p
n)
    rn_field :: GenLocated l (HsRecField' id (LHsExpr GhcPs))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated l (HsRecField' id (LHsExpr GhcRn)), FreeVars)
rn_field (L l
l HsRecField' id (LHsExpr GhcPs)
fld) = do { (LHsExpr GhcRn
arg', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr (HsRecField' id (LHsExpr GhcPs) -> LHsExpr GhcPs
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' id (LHsExpr GhcPs)
fld)
                            ; (GenLocated l (HsRecField' id (LHsExpr GhcRn)), FreeVars)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated l (HsRecField' id (LHsExpr GhcRn)), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (l
-> HsRecField' id (LHsExpr GhcRn)
-> GenLocated l (HsRecField' id (LHsExpr GhcRn))
forall l e. l -> e -> GenLocated l e
L l
l (HsRecField' id (LHsExpr GhcPs)
fld { hsRecFieldArg :: LHsExpr GhcRn
hsRecFieldArg = LHsExpr GhcRn
arg' }), FreeVars
fvs) }

rnExpr (RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcPs
expr, rupd_flds :: forall p. HsExpr p -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcPs]
rbinds })
  = do  { (LHsExpr GhcRn
expr', FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; ([LHsRecUpdField GhcRn]
rbinds', FreeVars
fvRbinds) <- [LHsRecUpdField GhcPs] -> RnM ([LHsRecUpdField GhcRn], FreeVars)
rnHsRecUpdFields [LHsRecUpdField GhcPs]
rbinds
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_ext :: XRecordUpd GhcRn
rupd_ext = XRecordUpd GhcRn
NoExtField
noExtField, rupd_expr :: LHsExpr GhcRn
rupd_expr = LHsExpr GhcRn
expr'
                            , rupd_flds :: [LHsRecUpdField GhcRn]
rupd_flds = [LHsRecUpdField GhcRn]
rbinds' }
                 , FreeVars
fvExpr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvRbinds) }

rnExpr (ExprWithTySig XExprWithTySig GhcPs
_ LHsExpr GhcPs
expr LHsSigWcType (NoGhcTc GhcPs)
pty)
  = do  { (LHsSigWcType GhcRn
pty', FreeVars
fvTy)    <- HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsSigWcTypeScoping
BindUnlessForall HsDocContext
ExprWithTySigCtx LHsSigWcType (NoGhcTc GhcPs)
LHsSigWcType GhcPs
pty
        ; (LHsExpr GhcRn
expr', FreeVars
fvExpr) <- [Name]
-> RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV (LHsSigWcType GhcRn -> [Name]
hsWcScopedTvs LHsSigWcType GhcRn
pty') (RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars))
-> RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                             LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExprWithTySig GhcRn
-> LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcRn
NoExtField
noExtField LHsExpr GhcRn
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
pty', FreeVars
fvExpr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvTy) }

rnExpr (HsIf XIf GhcPs
x Maybe (SyntaxExpr GhcPs)
_ LHsExpr GhcPs
p LHsExpr GhcPs
b1 LHsExpr GhcPs
b2)
  = do { (LHsExpr GhcRn
p', FreeVars
fvP) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
p
       ; (LHsExpr GhcRn
b1', FreeVars
fvB1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
b1
       ; (LHsExpr GhcRn
b2', FreeVars
fvB2) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
b2
       ; (Maybe (SyntaxExpr GhcRn)
mb_ite, FreeVars
fvITE) <- RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
lookupIfThenElse
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcRn
-> Maybe (SyntaxExpr GhcRn)
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> HsExpr GhcRn
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcPs
XIf GhcRn
x Maybe (SyntaxExpr GhcRn)
mb_ite LHsExpr GhcRn
p' LHsExpr GhcRn
b1' LHsExpr GhcRn
b2', [FreeVars] -> FreeVars
plusFVs [FreeVars
fvITE, FreeVars
fvP, FreeVars
fvB1, FreeVars
fvB2]) }

rnExpr (HsMultiIf XMultiIf GhcPs
x [LGRHS GhcPs (LHsExpr GhcPs)]
alts)
  = do { ([LGRHS GhcRn (LHsExpr GhcRn)]
alts', FreeVars
fvs) <- (LGRHS GhcPs (LHsExpr GhcPs)
 -> RnM (LGRHS GhcRn (LHsExpr GhcRn), FreeVars))
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> RnM ([LGRHS GhcRn (LHsExpr GhcRn)], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsMatchContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> LGRHS GhcPs (LHsExpr GhcPs)
-> RnM (LGRHS GhcRn (LHsExpr GhcRn), FreeVars)
forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LGRHS GhcPs (Located (body GhcPs))
-> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
rnGRHS HsMatchContext Name
forall id. HsMatchContext id
IfAlt LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr) [LGRHS GhcPs (LHsExpr GhcPs)]
alts
       -- ; return (HsMultiIf ty alts', fvs) }
       ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcRn -> [LGRHS GhcRn (LHsExpr GhcRn)] -> HsExpr GhcRn
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcPs
XMultiIf GhcRn
x [LGRHS GhcRn (LHsExpr GhcRn)]
alts', FreeVars
fvs) }

rnExpr (ArithSeq XArithSeq GhcPs
x Maybe (SyntaxExpr GhcPs)
_ ArithSeqInfo GhcPs
seq)
  = do { Bool
opt_OverloadedLists <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
       ; (ArithSeqInfo GhcRn
new_seq, FreeVars
fvs) <- ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq ArithSeqInfo GhcPs
seq
       ; if Bool
opt_OverloadedLists
           then do {
            ; (SyntaxExpr GhcRn
from_list_name, FreeVars
fvs') <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
fromListName
            ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XArithSeq GhcRn
-> Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> HsExpr GhcRn
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcPs
XArithSeq GhcRn
x (SyntaxExpr GhcRn -> Maybe (SyntaxExpr GhcRn)
forall a. a -> Maybe a
Just SyntaxExpr GhcRn
from_list_name) ArithSeqInfo GhcRn
new_seq
                     , FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs') }
           else
            (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XArithSeq GhcRn
-> Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> HsExpr GhcRn
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcPs
XArithSeq GhcRn
x Maybe (SyntaxExpr GhcRn)
forall a. Maybe a
Nothing ArithSeqInfo GhcRn
new_seq, FreeVars
fvs) }

{-
************************************************************************
*                                                                      *
        Static values
*                                                                      *
************************************************************************

For the static form we check that it is not used in splices.
We also collect the free variables of the term which come from
this module. See Note [Grand plan for static forms] in StaticPtrTable.
-}

rnExpr e :: HsExpr GhcPs
e@(HsStatic XStatic GhcPs
_ LHsExpr GhcPs
expr) = do
    -- Normally, you wouldn't be able to construct a static expression without
    -- first enabling -XStaticPointers in the first place, since that extension
    -- is what makes the parser treat `static` as a keyword. But this is not a
    -- sufficient safeguard, as one can construct static expressions by another
    -- mechanism: Template Haskell (see #14204). To ensure that GHC is
    -- absolutely prepared to cope with static forms, we check for
    -- -XStaticPointers here as well.
    Extension
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.StaticPointers (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
      MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal static expression:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
e)
                  Int
2 (String -> MsgDoc
text String
"Use StaticPointers to enable this extension")
    (LHsExpr GhcRn
expr',FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
    ThStage
stage <- TcM ThStage
getStage
    case ThStage
stage of
      Splice SpliceType
_ -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
sep
             [ String -> MsgDoc
text String
"static forms cannot be used in splices:"
             , Int -> MsgDoc -> MsgDoc
nest Int
2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
e
             ]
      ThStage
_ -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    let fvExpr' :: FreeVars
fvExpr' = (Name -> Bool) -> FreeVars -> FreeVars
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) FreeVars
fvExpr
    (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XStatic GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic FreeVars
XStatic GhcRn
fvExpr' LHsExpr GhcRn
expr', FreeVars
fvExpr)

{-
************************************************************************
*                                                                      *
        Arrow notation
*                                                                      *
************************************************************************
-}

rnExpr (HsProc XProc GhcPs
x LPat GhcPs
pat LHsCmdTop GhcPs
body)
  = RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall a. TcM a -> TcM a
newArrowScope (RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
    HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars)
forall a.
HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat HsMatchContext Name
forall id. HsMatchContext id
ProcExpr LPat GhcPs
pat ((LPat GhcRn -> RnM (HsExpr GhcRn, FreeVars))
 -> RnM (HsExpr GhcRn, FreeVars))
-> (LPat GhcRn -> RnM (HsExpr GhcRn, FreeVars))
-> RnM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
pat' -> do
      { (LHsCmdTop GhcRn
body',FreeVars
fvBody) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
body
      ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XProc GhcRn -> LPat GhcRn -> LHsCmdTop GhcRn -> HsExpr GhcRn
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcPs
XProc GhcRn
x LPat GhcRn
pat' LHsCmdTop GhcRn
body', FreeVars
fvBody) }

rnExpr HsExpr GhcPs
other = String -> MsgDoc -> RnM (HsExpr GhcRn, FreeVars)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnExpr: unexpected expression" (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
other)
        -- HsWrap

----------------------
-- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection section :: HsExpr GhcPs
section@(SectionR XSectionR GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
expr)
  = do  { (LHsExpr GhcRn
op', FreeVars
fvs_op)     <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
op
        ; (LHsExpr GhcRn
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; FixityDirection
-> HsExpr GhcPs
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkSectionPrec FixityDirection
InfixR HsExpr GhcPs
section LHsExpr GhcRn
op' LHsExpr GhcRn
expr'
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSectionR GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
XSectionR GhcRn
x LHsExpr GhcRn
op' LHsExpr GhcRn
expr', FreeVars
fvs_op FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_expr) }

rnSection section :: HsExpr GhcPs
section@(SectionL XSectionL GhcPs
x LHsExpr GhcPs
expr LHsExpr GhcPs
op)
  = do  { (LHsExpr GhcRn
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
        ; (LHsExpr GhcRn
op', FreeVars
fvs_op)     <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
op
        ; FixityDirection
-> HsExpr GhcPs
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkSectionPrec FixityDirection
InfixL HsExpr GhcPs
section LHsExpr GhcRn
op' LHsExpr GhcRn
expr'
        ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSectionL GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
XSectionL GhcRn
x LHsExpr GhcRn
expr' LHsExpr GhcRn
op', FreeVars
fvs_op FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_expr) }

rnSection HsExpr GhcPs
other = String -> MsgDoc -> RnM (HsExpr GhcRn, FreeVars)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnSection" (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
other)

{-
************************************************************************
*                                                                      *
        Arrow commands
*                                                                      *
************************************************************************
-}

rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [] = ([LHsCmdTop GhcRn], FreeVars) -> RnM ([LHsCmdTop GhcRn], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyFVs)
rnCmdArgs (LHsCmdTop GhcPs
arg:[LHsCmdTop GhcPs]
args)
  = do { (LHsCmdTop GhcRn
arg',FreeVars
fvArg) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg
       ; ([LHsCmdTop GhcRn]
args',FreeVars
fvArgs) <- [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [LHsCmdTop GhcPs]
args
       ; ([LHsCmdTop GhcRn], FreeVars) -> RnM ([LHsCmdTop GhcRn], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsCmdTop GhcRn
arg'LHsCmdTop GhcRn -> [LHsCmdTop GhcRn] -> [LHsCmdTop GhcRn]
forall a. a -> [a] -> [a]
:[LHsCmdTop GhcRn]
args', FreeVars
fvArg FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArgs) }

rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = (SrcSpanLess (LHsCmdTop GhcPs)
 -> TcM (SrcSpanLess (LHsCmdTop GhcRn), FreeVars))
-> LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LHsCmdTop GhcPs)
-> TcM (SrcSpanLess (LHsCmdTop GhcRn), FreeVars)
HsCmdTop GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsCmdTop GhcRn, FreeVars)
rnCmdTop'
 where
  rnCmdTop' :: HsCmdTop GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsCmdTop GhcRn, FreeVars)
rnCmdTop' (HsCmdTop XCmdTop GhcPs
_ LHsCmd GhcPs
cmd)
   = do { (LHsCmd GhcRn
cmd', FreeVars
fvCmd) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
cmd
        ; let cmd_names :: [Name]
cmd_names = [Name
arrAName, Name
composeAName, Name
firstAName] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                          FreeVars -> [Name]
nameSetElemsStable (HsCmd GhcRn -> FreeVars
methodNamesCmd (LHsCmd GhcRn -> SrcSpanLess (LHsCmd GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsCmd GhcRn
cmd'))
        -- Generate the rebindable syntax for the monad
        ; ([HsExpr GhcRn]
cmd_names', FreeVars
cmd_fvs) <- [Name] -> RnM ([HsExpr GhcRn], FreeVars)
lookupSyntaxNames [Name]
cmd_names

        ; (HsCmdTop GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsCmdTop GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdTop GhcRn -> LHsCmd GhcRn -> HsCmdTop GhcRn
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop ([Name]
cmd_names [Name] -> [HsExpr GhcRn] -> [(Name, HsExpr GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [HsExpr GhcRn]
cmd_names') LHsCmd GhcRn
cmd',
                  FreeVars
fvCmd FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
cmd_fvs) }
  rnCmdTop' (XCmdTop XXCmdTop GhcPs
nec) = NoExtCon
-> IOEnv (Env TcGblEnv TcLclEnv) (HsCmdTop GhcRn, FreeVars)
forall a. NoExtCon -> a
noExtCon XXCmdTop GhcPs
NoExtCon
nec

rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = (SrcSpanLess (LHsCmd GhcPs)
 -> TcM (SrcSpanLess (LHsCmd GhcRn), FreeVars))
-> LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
forall a b c.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b, c)) -> a -> TcM (b, c)
wrapLocFstM SrcSpanLess (LHsCmd GhcPs)
-> TcM (SrcSpanLess (LHsCmd GhcRn), FreeVars)
HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd

rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)

rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd (HsCmdArrApp XCmdArrApp GhcPs
x LHsExpr GhcPs
arrow LHsExpr GhcPs
arg HsArrAppType
ho Bool
rtl)
  = do { (LHsExpr GhcRn
arrow',FreeVars
fvArrow) <- RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
select_arrow_scope (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
arrow)
       ; (LHsExpr GhcRn
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
arg
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrApp GhcRn
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> HsArrAppType
-> Bool
-> HsCmd GhcRn
forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp XCmdArrApp GhcPs
XCmdArrApp GhcRn
x LHsExpr GhcRn
arrow' LHsExpr GhcRn
arg' HsArrAppType
ho Bool
rtl,
                 FreeVars
fvArrow FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }
  where
    select_arrow_scope :: RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
select_arrow_scope RnM (LHsExpr GhcRn, FreeVars)
tc = case HsArrAppType
ho of
        HsArrAppType
HsHigherOrderApp -> RnM (LHsExpr GhcRn, FreeVars)
tc
        HsArrAppType
HsFirstOrderApp  -> RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall a. TcM a -> TcM a
escapeArrowScope RnM (LHsExpr GhcRn, FreeVars)
tc
        -- See Note [Escaping the arrow scope] in TcRnTypes
        -- Before renaming 'arrow', use the environment of the enclosing
        -- proc for the (-<) case.
        -- Local bindings, inside the enclosing proc, are not in scope
        -- inside 'arrow'.  In the higher-order case (-<<), they are.

-- infix form
rnCmd (HsCmdArrForm XCmdArrForm GhcPs
_ LHsExpr GhcPs
op LexicalFixity
_ (Just Fixity
_) [LHsCmdTop GhcPs
arg1, LHsCmdTop GhcPs
arg2])
  = do { (LHsExpr GhcRn
op',FreeVars
fv_op) <- RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall a. TcM a -> TcM a
escapeArrowScope (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
op)
       ; let L SrcSpan
_ (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
op_name)) = LHsExpr GhcRn
op'
       ; (LHsCmdTop GhcRn
arg1',FreeVars
fv_arg1) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg1
       ; (LHsCmdTop GhcRn
arg2',FreeVars
fv_arg2) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg2
        -- Deal with fixity
       ; Fixity
fixity <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
IdP GhcRn
op_name
       ; HsCmd GhcRn
final_e <- LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsCmdTop GhcRn -> RnM (HsCmd GhcRn)
mkOpFormRn LHsCmdTop GhcRn
arg1' LHsExpr GhcRn
op' Fixity
fixity LHsCmdTop GhcRn
arg2'
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsCmd GhcRn
final_e, FreeVars
fv_arg1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_op FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_arg2) }

rnCmd (HsCmdArrForm XCmdArrForm GhcPs
x LHsExpr GhcPs
op LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcPs]
cmds)
  = do { (LHsExpr GhcRn
op',FreeVars
fvOp) <- RnM (LHsExpr GhcRn, FreeVars) -> RnM (LHsExpr GhcRn, FreeVars)
forall a. TcM a -> TcM a
escapeArrowScope (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
op)
       ; ([LHsCmdTop GhcRn]
cmds',FreeVars
fvCmds) <- [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [LHsCmdTop GhcPs]
cmds
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcPs
XCmdArrForm GhcRn
x LHsExpr GhcRn
op' LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcRn]
cmds', FreeVars
fvOp FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvCmds) }

rnCmd (HsCmdApp XCmdApp GhcPs
x LHsCmd GhcPs
fun LHsExpr GhcPs
arg)
  = do { (LHsCmd GhcRn
fun',FreeVars
fvFun) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd  LHsCmd GhcPs
fun
       ; (LHsExpr GhcRn
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
arg
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdApp GhcRn -> LHsCmd GhcRn -> LHsExpr GhcRn -> HsCmd GhcRn
forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcPs
XCmdApp GhcRn
x LHsCmd GhcRn
fun' LHsExpr GhcRn
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }

rnCmd (HsCmdLam XCmdLam GhcPs
x MatchGroup GhcPs (LHsCmd GhcPs)
matches)
  = do { (MatchGroup GhcRn (LHsCmd GhcRn)
matches', FreeVars
fvMatch) <- HsMatchContext Name
-> (LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars))
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> RnM (MatchGroup GhcRn (LHsCmd GhcRn), FreeVars)
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
matches
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdLam GhcRn -> MatchGroup GhcRn (LHsCmd GhcRn) -> HsCmd GhcRn
forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam XCmdLam GhcPs
XCmdLam GhcRn
x MatchGroup GhcRn (LHsCmd GhcRn)
matches', FreeVars
fvMatch) }

rnCmd (HsCmdPar XCmdPar GhcPs
x LHsCmd GhcPs
e)
  = do  { (LHsCmd GhcRn
e', FreeVars
fvs_e) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
e
        ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdPar GhcRn -> LHsCmd GhcRn -> HsCmd GhcRn
forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcPs
XCmdPar GhcRn
x LHsCmd GhcRn
e', FreeVars
fvs_e) }

rnCmd (HsCmdCase XCmdCase GhcPs
x LHsExpr GhcPs
expr MatchGroup GhcPs (LHsCmd GhcPs)
matches)
  = do { (LHsExpr GhcRn
new_expr, FreeVars
e_fvs) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
       ; (MatchGroup GhcRn (LHsCmd GhcRn)
new_matches, FreeVars
ms_fvs) <- HsMatchContext Name
-> (LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars))
-> MatchGroup GhcPs (LHsCmd GhcPs)
-> RnM (MatchGroup GhcRn (LHsCmd GhcRn), FreeVars)
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContext Name
forall id. HsMatchContext id
CaseAlt LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
matches
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdCase GhcRn
-> LHsExpr GhcRn -> MatchGroup GhcRn (LHsCmd GhcRn) -> HsCmd GhcRn
forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase XCmdCase GhcPs
XCmdCase GhcRn
x LHsExpr GhcRn
new_expr MatchGroup GhcRn (LHsCmd GhcRn)
new_matches, FreeVars
e_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
ms_fvs) }

rnCmd (HsCmdIf XCmdIf GhcPs
x Maybe (SyntaxExpr GhcPs)
_ LHsExpr GhcPs
p LHsCmd GhcPs
b1 LHsCmd GhcPs
b2)
  = do { (LHsExpr GhcRn
p', FreeVars
fvP) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
p
       ; (LHsCmd GhcRn
b1', FreeVars
fvB1) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
b1
       ; (LHsCmd GhcRn
b2', FreeVars
fvB2) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
b2
       ; (Maybe (SyntaxExpr GhcRn)
mb_ite, FreeVars
fvITE) <- RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
lookupIfThenElse
       ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdIf GhcRn
-> Maybe (SyntaxExpr GhcRn)
-> LHsExpr GhcRn
-> LHsCmd GhcRn
-> LHsCmd GhcRn
-> HsCmd GhcRn
forall id.
XCmdIf id
-> Maybe (SyntaxExpr id)
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf XCmdIf GhcPs
XCmdIf GhcRn
x Maybe (SyntaxExpr GhcRn)
mb_ite LHsExpr GhcRn
p' LHsCmd GhcRn
b1' LHsCmd GhcRn
b2', [FreeVars] -> FreeVars
plusFVs [FreeVars
fvITE, FreeVars
fvP, FreeVars
fvB1, FreeVars
fvB2])}

rnCmd (HsCmdLet XCmdLet GhcPs
x (L SrcSpan
l HsLocalBinds GhcPs
binds) LHsCmd GhcPs
cmd)
  = HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (HsCmd GhcRn, FreeVars))
-> RnM (HsCmd GhcRn, FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn -> FreeVars -> RnM (HsCmd GhcRn, FreeVars))
 -> RnM (HsCmd GhcRn, FreeVars))
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (HsCmd GhcRn, FreeVars))
-> RnM (HsCmd GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcRn
binds' FreeVars
_ -> do
      { (LHsCmd GhcRn
cmd',FreeVars
fvExpr) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
cmd
      ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdLet GhcRn -> LHsLocalBinds GhcRn -> LHsCmd GhcRn -> HsCmd GhcRn
forall id. XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet XCmdLet GhcPs
XCmdLet GhcRn
x (SrcSpan -> HsLocalBinds GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcRn
binds') LHsCmd GhcRn
cmd', FreeVars
fvExpr) }

rnCmd (HsCmdDo XCmdDo GhcPs
x (L SrcSpan
l [CmdLStmt GhcPs]
stmts))
  = do  { (([LStmt GhcRn (LHsCmd GhcRn)]
stmts', ()
_), FreeVars
fvs) <-
            HsStmtContext Name
-> (LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars))
-> [CmdLStmt GhcPs]
-> ([Name] -> RnM ((), FreeVars))
-> RnM (([LStmt GhcRn (LHsCmd GhcRn)], ()), FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext Name
forall id. HsStmtContext id
ArrowExpr LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd [CmdLStmt GhcPs]
stmts (\ [Name]
_ -> ((), FreeVars) -> RnM ((), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
        ; (HsCmd GhcRn, FreeVars) -> RnM (HsCmd GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XCmdDo GhcRn -> Located [LStmt GhcRn (LHsCmd GhcRn)] -> HsCmd GhcRn
forall id. XCmdDo id -> Located [CmdLStmt id] -> HsCmd id
HsCmdDo XCmdDo GhcPs
XCmdDo GhcRn
x (SrcSpan
-> [LStmt GhcRn (LHsCmd GhcRn)]
-> Located [LStmt GhcRn (LHsCmd GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LStmt GhcRn (LHsCmd GhcRn)]
stmts'), FreeVars
fvs ) }

rnCmd cmd :: HsCmd GhcPs
cmd@(HsCmdWrap {}) = String -> MsgDoc -> RnM (HsCmd GhcRn, FreeVars)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rnCmd" (HsCmd GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsCmd GhcPs
cmd)
rnCmd     (XCmd XXCmd GhcPs
nec)     = NoExtCon -> RnM (HsCmd GhcRn, FreeVars)
forall a. NoExtCon -> a
noExtCon XXCmd GhcPs
NoExtCon
nec

---------------------------------------------------
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName

-- find what methods the Cmd needs (loop, choice, apply)
methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
methodNamesLCmd :: LHsCmd GhcRn -> FreeVars
methodNamesLCmd = HsCmd GhcRn -> FreeVars
methodNamesCmd (HsCmd GhcRn -> FreeVars)
-> (LHsCmd GhcRn -> HsCmd GhcRn) -> LHsCmd GhcRn -> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsCmd GhcRn -> HsCmd GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

methodNamesCmd :: HsCmd GhcRn -> CmdNeeds

methodNamesCmd :: HsCmd GhcRn -> FreeVars
methodNamesCmd (HsCmdArrApp XCmdArrApp GhcRn
_ LHsExpr GhcRn
_arrow LHsExpr GhcRn
_arg HsArrAppType
HsFirstOrderApp Bool
_rtl)
  = FreeVars
emptyFVs
methodNamesCmd (HsCmdArrApp XCmdArrApp GhcRn
_ LHsExpr GhcRn
_arrow LHsExpr GhcRn
_arg HsArrAppType
HsHigherOrderApp Bool
_rtl)
  = Name -> FreeVars
unitFV Name
appAName
methodNamesCmd (HsCmdArrForm {}) = FreeVars
emptyFVs
methodNamesCmd (HsCmdWrap XCmdWrap GhcRn
_ HsWrapper
_ HsCmd GhcRn
cmd) = HsCmd GhcRn -> FreeVars
methodNamesCmd HsCmd GhcRn
cmd

methodNamesCmd (HsCmdPar XCmdPar GhcRn
_ LHsCmd GhcRn
c) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c

methodNamesCmd (HsCmdIf XCmdIf GhcRn
_ Maybe (SyntaxExpr GhcRn)
_ LHsExpr GhcRn
_ LHsCmd GhcRn
c1 LHsCmd GhcRn
c2)
  = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c1 FreeVars -> FreeVars -> FreeVars
`plusFV` LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c2 FreeVars -> Name -> FreeVars
`addOneFV` Name
choiceAName

methodNamesCmd (HsCmdLet XCmdLet GhcRn
_ LHsLocalBinds GhcRn
_ LHsCmd GhcRn
c)          = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c
methodNamesCmd (HsCmdDo XCmdDo GhcRn
_ (L SrcSpan
_ [LStmt GhcRn (LHsCmd GhcRn)]
stmts))   = [LStmt GhcRn (LHsCmd GhcRn)] -> FreeVars
methodNamesStmts [LStmt GhcRn (LHsCmd GhcRn)]
stmts
methodNamesCmd (HsCmdApp XCmdApp GhcRn
_ LHsCmd GhcRn
c LHsExpr GhcRn
_)          = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c
methodNamesCmd (HsCmdLam XCmdLam GhcRn
_ MatchGroup GhcRn (LHsCmd GhcRn)
match)        = MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch MatchGroup GhcRn (LHsCmd GhcRn)
match

methodNamesCmd (HsCmdCase XCmdCase GhcRn
_ LHsExpr GhcRn
_ MatchGroup GhcRn (LHsCmd GhcRn)
matches)
  = MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch MatchGroup GhcRn (LHsCmd GhcRn)
matches FreeVars -> Name -> FreeVars
`addOneFV` Name
choiceAName

methodNamesCmd (XCmd XXCmd GhcRn
nec) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXCmd GhcRn
NoExtCon
nec

--methodNamesCmd _ = emptyFVs
   -- Other forms can't occur in commands, but it's not convenient
   -- to error here so we just do what's convenient.
   -- The type checker will complain later

---------------------------------------------------
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = L SrcSpan
_ [LMatch GhcRn (LHsCmd GhcRn)]
ms })
  = [FreeVars] -> FreeVars
plusFVs ((LMatch GhcRn (LHsCmd GhcRn) -> FreeVars)
-> [LMatch GhcRn (LHsCmd GhcRn)] -> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map LMatch GhcRn (LHsCmd GhcRn) -> FreeVars
forall l. GenLocated l (Match GhcRn (LHsCmd GhcRn)) -> FreeVars
do_one [LMatch GhcRn (LHsCmd GhcRn)]
ms)
 where
    do_one :: GenLocated l (Match GhcRn (LHsCmd GhcRn)) -> FreeVars
do_one (L l
_ (Match { m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LHsCmd GhcRn)
grhss })) = GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs GRHSs GhcRn (LHsCmd GhcRn)
grhss
    do_one (L l
_ (XMatch XXMatch GhcRn (LHsCmd GhcRn)
nec)) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXMatch GhcRn (LHsCmd GhcRn)
NoExtCon
nec
methodNamesMatch (XMatchGroup XXMatchGroup GhcRn (LHsCmd GhcRn)
nec) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXMatchGroup GhcRn (LHsCmd GhcRn)
NoExtCon
nec

-------------------------------------------------
-- gaw 2004
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs (GRHSs XCGRHSs GhcRn (LHsCmd GhcRn)
_ [LGRHS GhcRn (LHsCmd GhcRn)]
grhss LHsLocalBinds GhcRn
_) = [FreeVars] -> FreeVars
plusFVs ((LGRHS GhcRn (LHsCmd GhcRn) -> FreeVars)
-> [LGRHS GhcRn (LHsCmd GhcRn)] -> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map LGRHS GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHS [LGRHS GhcRn (LHsCmd GhcRn)]
grhss)
methodNamesGRHSs (XGRHSs XXGRHSs GhcRn (LHsCmd GhcRn)
nec) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXGRHSs GhcRn (LHsCmd GhcRn)
NoExtCon
nec

-------------------------------------------------

methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS :: LGRHS GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHS (L SrcSpan
_ (GRHS XCGRHS GhcRn (LHsCmd GhcRn)
_ [LStmt GhcRn (LHsExpr GhcRn)]
_ LHsCmd GhcRn
rhs)) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
rhs
methodNamesGRHS (L SrcSpan
_ (XGRHS XXGRHS GhcRn (LHsCmd GhcRn)
nec)) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXGRHS GhcRn (LHsCmd GhcRn)
NoExtCon
nec

---------------------------------------------------
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
methodNamesStmts :: [LStmt GhcRn (LHsCmd GhcRn)] -> FreeVars
methodNamesStmts [LStmt GhcRn (LHsCmd GhcRn)]
stmts = [FreeVars] -> FreeVars
plusFVs ((LStmt GhcRn (LHsCmd GhcRn) -> FreeVars)
-> [LStmt GhcRn (LHsCmd GhcRn)] -> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map LStmt GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesLStmt [LStmt GhcRn (LHsCmd GhcRn)]
stmts)

---------------------------------------------------
methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesLStmt :: LStmt GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesLStmt = StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt (StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars)
-> (LStmt GhcRn (LHsCmd GhcRn)
    -> StmtLR GhcRn GhcRn (LHsCmd GhcRn))
-> LStmt GhcRn (LHsCmd GhcRn)
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LStmt GhcRn (LHsCmd GhcRn) -> StmtLR GhcRn GhcRn (LHsCmd GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt (LastStmt XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LHsCmd GhcRn
cmd Bool
_ SyntaxExpr GhcRn
_)           = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
cmd
methodNamesStmt (BodyStmt XBodyStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LHsCmd GhcRn
cmd SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_)           = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
cmd
methodNamesStmt (BindStmt XBindStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LPat GhcRn
_ LHsCmd GhcRn
cmd SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_)         = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
cmd
methodNamesStmt (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [LStmt GhcRn (LHsCmd GhcRn)]
stmts }) =
  [LStmt GhcRn (LHsCmd GhcRn)] -> FreeVars
methodNamesStmts [LStmt GhcRn (LHsCmd GhcRn)]
stmts FreeVars -> Name -> FreeVars
`addOneFV` Name
loopAName
methodNamesStmt (LetStmt {})                   = FreeVars
emptyFVs
methodNamesStmt (ParStmt {})                   = FreeVars
emptyFVs
methodNamesStmt (TransStmt {})                 = FreeVars
emptyFVs
methodNamesStmt ApplicativeStmt{}              = FreeVars
emptyFVs
   -- ParStmt and TransStmt can't occur in commands, but it's not
   -- convenient to error here so we just do what's convenient
methodNamesStmt (XStmtLR XXStmtLR GhcRn GhcRn (LHsCmd GhcRn)
nec) = NoExtCon -> FreeVars
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcRn GhcRn (LHsCmd GhcRn)
NoExtCon
nec

{-
************************************************************************
*                                                                      *
        Arithmetic sequences
*                                                                      *
************************************************************************
-}

rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq (From LHsExpr GhcPs
expr)
 = do { (LHsExpr GhcRn
expr', FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr
      ; (ArithSeqInfo GhcRn, FreeVars)
-> RnM (ArithSeqInfo GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> ArithSeqInfo GhcRn
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcRn
expr', FreeVars
fvExpr) }

rnArithSeq (FromThen LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
 = do { (LHsExpr GhcRn
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr1
      ; (LHsExpr GhcRn
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr2
      ; (ArithSeqInfo GhcRn, FreeVars)
-> RnM (ArithSeqInfo GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> LHsExpr GhcRn -> ArithSeqInfo GhcRn
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcRn
expr1' LHsExpr GhcRn
expr2', FreeVars
fvExpr1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr2) }

rnArithSeq (FromTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
 = do { (LHsExpr GhcRn
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr1
      ; (LHsExpr GhcRn
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr2
      ; (ArithSeqInfo GhcRn, FreeVars)
-> RnM (ArithSeqInfo GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> LHsExpr GhcRn -> ArithSeqInfo GhcRn
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcRn
expr1' LHsExpr GhcRn
expr2', FreeVars
fvExpr1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr2) }

rnArithSeq (FromThenTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2 LHsExpr GhcPs
expr3)
 = do { (LHsExpr GhcRn
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr1
      ; (LHsExpr GhcRn
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr2
      ; (LHsExpr GhcRn
expr3', FreeVars
fvExpr3) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
expr3
      ; (ArithSeqInfo GhcRn, FreeVars)
-> RnM (ArithSeqInfo GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> ArithSeqInfo GhcRn
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcRn
expr1' LHsExpr GhcRn
expr2' LHsExpr GhcRn
expr3',
                [FreeVars] -> FreeVars
plusFVs [FreeVars
fvExpr1, FreeVars
fvExpr2, FreeVars
fvExpr3]) }

{-
************************************************************************
*                                                                      *
\subsubsection{@Stmt@s: in @do@ expressions}
*                                                                      *
************************************************************************
-}

{-
Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Both ApplicativeDo and RecursiveDo need to create tuples not
present in the source text.

For ApplicativeDo we create:

  (a,b,c) <- (\c b a -> (a,b,c)) <$>

For RecursiveDo we create:

  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))

The order of the components in those tuples needs to be stable
across recompilations, otherwise they can get optimized differently
and we end up with incompatible binaries.
To get a stable order we use nameSetElemsStable.
See Note [Deterministic UniqFM] to learn more about nondeterminism.
-}

-- | Rename some Stmts
rnStmts :: Outputable (body GhcPs)
        => HsStmtContext Name
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
        -> [LStmt GhcPs (Located (body GhcPs))]
           -- ^ Statements
        -> ([Name] -> RnM (thing, FreeVars))
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts :: HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody = HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> (HsStmtContext Name
    -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
    -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> (HsStmtContext Name
    -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
    -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
forall (body :: * -> *).
HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts

-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
rnStmtsWithPostProcessing
        :: Outputable (body GhcPs)
        => HsStmtContext Name
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
        -> (HsStmtContext Name
              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
           -- ^ postprocess the statements
        -> [LStmt GhcPs (Located (body GhcPs))]
           -- ^ Statements
        -> ([Name] -> RnM (thing, FreeVars))
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing :: HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> (HsStmtContext Name
    -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
    -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
ppStmts [LStmt GhcPs (Located (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
 = do { (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts', thing
thing), FreeVars
fvs) <-
          HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmtsWithFreeVars HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [LStmt GhcPs (Located (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
      ; ([LStmt GhcRn (Located (body GhcRn))]
pp_stmts, FreeVars
fvs') <- HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
ppStmts HsStmtContext Name
ctxt [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts'
      ; (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([LStmt GhcRn (Located (body GhcRn))]
pp_stmts, thing
thing), FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs')
      }

-- | maybe rearrange statements according to the ApplicativeDo transformation
postProcessStmtsForApplicativeDo
  :: HsStmtContext Name
  -> [(ExprLStmt GhcRn, FreeVars)]
  -> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo :: HsStmtContext Name
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
postProcessStmtsForApplicativeDo HsStmtContext Name
ctxt [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
  = do {
       -- rearrange the statements using ApplicativeStmt if
       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
       -- to each Stmt body.
         Bool
ado_is_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ApplicativeDo
       ; let is_do_expr :: Bool
is_do_expr | HsStmtContext Name
DoExpr <- HsStmtContext Name
ctxt = Bool
True
                        | Bool
otherwise = Bool
False
       -- don't apply the transformation inside TH brackets, because
       -- DsMeta does not handle ApplicativeDo.
       ; Bool
in_th_bracket <- ThStage -> Bool
isBrackStage (ThStage -> Bool) -> TcM ThStage -> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcM ThStage
getStage
       ; if Bool
ado_is_on Bool -> Bool -> Bool
&& Bool
is_do_expr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
in_th_bracket
            then do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"ppsfa" ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts)
                    ; HsStmtContext Name
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
rearrangeForApplicativeDo HsStmtContext Name
ctxt [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts }
            else HsStmtContext Name
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (body :: * -> *).
HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts HsStmtContext Name
ctxt [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts }

-- | strip the FreeVars annotations from statements
noPostProcessStmts
  :: HsStmtContext Name
  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts :: HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts HsStmtContext Name
_ [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts = ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (((LStmt GhcRn (Located (body GhcRn)), FreeVars)
 -> LStmt GhcRn (Located (body GhcRn)))
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [LStmt GhcRn (Located (body GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (LStmt GhcRn (Located (body GhcRn)), FreeVars)
-> LStmt GhcRn (Located (body GhcRn))
forall a b. (a, b) -> a
fst [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts, FreeVars
emptyNameSet)


rnStmtsWithFreeVars :: Outputable (body GhcPs)
        => HsStmtContext Name
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
        -> [LStmt GhcPs (Located (body GhcPs))]
        -> ([Name] -> RnM (thing, FreeVars))
        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
               , FreeVars)
-- Each Stmt body is annotated with its FreeVars, so that
-- we can rearrange statements for ApplicativeDo.
--
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars

rnStmtsWithFreeVars :: HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmtsWithFreeVars HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [] [Name] -> RnM (thing, FreeVars)
thing_inside
  = do { HsStmtContext Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContext Name
ctxt
       ; (thing
thing, FreeVars
fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
       ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([], thing
thing), FreeVars
fvs) }

rnStmtsWithFreeVars HsStmtContext Name
MDoExpr Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [LStmt GhcPs (Located (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside    -- Deal with mdo
  = -- Behave like do { rec { ...all but last... }; last }
    do { (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts1, ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts2, thing
thing)), FreeVars
fvs)
           <- HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmt HsStmtContext Name
forall id. HsStmtContext id
MDoExpr Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (SrcSpanLess (LStmt GhcPs (Located (body GhcPs)))
-> LStmt GhcPs (Located (body GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LStmt GhcPs (Located (body GhcPs)))
 -> LStmt GhcPs (Located (body GhcPs)))
-> SrcSpanLess (LStmt GhcPs (Located (body GhcPs)))
-> LStmt GhcPs (Located (body GhcPs))
forall a b. (a -> b) -> a -> b
$ [LStmt GhcPs (Located (body GhcPs))]
-> StmtLR GhcPs GhcPs (Located (body GhcPs))
forall (idL :: Pass) bodyR.
[LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt [LStmt GhcPs (Located (body GhcPs))]
all_but_last) (([Name]
  -> RnM
       (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
        FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
        ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
       FreeVars))
-> ([Name]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
_ ->
              do { LStmt GhcPs (Located (body GhcPs))
last_stmt' <- HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt HsStmtContext Name
forall id. HsStmtContext id
MDoExpr LStmt GhcPs (Located (body GhcPs))
last_stmt
                 ; HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmt HsStmtContext Name
forall id. HsStmtContext id
MDoExpr Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody LStmt GhcPs (Located (body GhcPs))
last_stmt' [Name] -> RnM (thing, FreeVars)
thing_inside }
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts1 [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
forall a. [a] -> [a] -> [a]
++ [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts2), thing
thing), FreeVars
fvs) }
  where
    Just ([LStmt GhcPs (Located (body GhcPs))]
all_but_last, LStmt GhcPs (Located (body GhcPs))
last_stmt) = [LStmt GhcPs (Located (body GhcPs))]
-> Maybe
     ([LStmt GhcPs (Located (body GhcPs))],
      LStmt GhcPs (Located (body GhcPs)))
forall a. [a] -> Maybe ([a], a)
snocView [LStmt GhcPs (Located (body GhcPs))]
stmts

rnStmtsWithFreeVars HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (lstmt :: LStmt GhcPs (Located (body GhcPs))
lstmt@(L SrcSpan
loc StmtLR GhcPs GhcPs (Located (body GhcPs))
_) : [LStmt GhcPs (Located (body GhcPs))]
lstmts) [Name] -> RnM (thing, FreeVars)
thing_inside
  | [LStmt GhcPs (Located (body GhcPs))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LStmt GhcPs (Located (body GhcPs))]
lstmts
  = SrcSpan
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM
   (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
    FreeVars)
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
       FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a b. (a -> b) -> a -> b
$
    do { LStmt GhcPs (Located (body GhcPs))
lstmt' <- HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (body :: * -> *).
Outputable (body GhcPs) =>
HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt HsStmtContext Name
ctxt LStmt GhcPs (Located (body GhcPs))
lstmt
       ; HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody LStmt GhcPs (Located (body GhcPs))
lstmt' [Name] -> RnM (thing, FreeVars)
thing_inside }

  | Bool
otherwise
  = do { (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts1, ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts2, thing
thing)), FreeVars
fvs)
            <- SrcSpan
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc                         (RnM
   (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
     ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
    FreeVars)
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
        ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
       FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall a b. (a -> b) -> a -> b
$
               do { HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (body :: * -> *).
HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext Name
ctxt LStmt GhcPs (Located (body GhcPs))
lstmt
                  ; HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody LStmt GhcPs (Located (body GhcPs))
lstmt    (([Name]
  -> RnM
       (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
        FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
        ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
       FreeVars))
-> ([Name]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
       ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs1 ->
                    HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmtsWithFreeVars HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [LStmt GhcPs (Located (body GhcPs))]
lstmts  (([Name] -> RnM (thing, FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
       FreeVars))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs2 ->
                    [Name] -> RnM (thing, FreeVars)
thing_inside ([Name]
bndrs1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bndrs2) }
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((([(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts1 [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
forall a. [a] -> [a] -> [a]
++ [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts2), thing
thing), FreeVars
fvs) }

----------------------

{-
Note [Failing pattern matches in Stmts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Many things desugar to HsStmts including monadic things like `do` and `mdo`
statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
exhaustive list). How we deal with pattern match failure is context-dependent.

 * In the case of list comprehensions and pattern guards we don't need any 'fail'
   function; the desugarer ignores the fail function field of 'BindStmt' entirely.
 * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
   expressions) we want pattern match failure to be desugared to the appropriate
   'fail' function (either that of Monad or MonadFail, depending on whether
   -XMonadFailDesugaring is enabled.)

At one point we failed to make this distinction, leading to #11216.
-}

rnStmt :: Outputable (body GhcPs)
       => HsStmtContext Name
       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
          -- ^ How to rename the body of the statement
       -> LStmt GhcPs (Located (body GhcPs))
          -- ^ The statement
       -> ([Name] -> RnM (thing, FreeVars))
          -- ^ Rename the stuff that this statement scopes over
       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
              , FreeVars)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars

rnStmt :: HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (L SrcSpan
loc (LastStmt XLastStmt GhcPs GhcPs (Located (body GhcPs))
_ Located (body GhcPs)
body Bool
noret SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { (Located (body GhcRn)
body', FreeVars
fv_expr) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
        ; (SyntaxExpr GhcRn
ret_op, FreeVars
fvs1) <- if HsStmtContext Name -> Bool
forall id. HsStmtContext id -> Bool
isMonadCompContext HsStmtContext Name
ctxt
                            then HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
returnMName
                            else (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)
                            -- The 'return' in a LastStmt is used only
                            -- for MonadComp; and we don't want to report
                            -- "non in scope: return" in other cases
                            -- #15607

        ; (thing
thing,  FreeVars
fvs3) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([(SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLastStmt GhcRn GhcRn (Located (body GhcRn))
-> Located (body GhcRn)
-> Bool
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField Located (body GhcRn)
body' Bool
noret SyntaxExpr GhcRn
ret_op), FreeVars
fv_expr)]
                  , thing
thing), FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }

rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (L SrcSpan
loc (BodyStmt XBodyStmt GhcPs GhcPs (Located (body GhcPs))
_ Located (body GhcPs)
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { (Located (body GhcRn)
body', FreeVars
fv_expr) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
        ; (SyntaxExpr GhcRn
then_op, FreeVars
fvs1)  <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
thenMName

        ; (SyntaxExpr GhcRn
guard_op, FreeVars
fvs2) <- if HsStmtContext Name -> Bool
forall id. HsStmtContext id -> Bool
isComprehensionContext HsStmtContext Name
ctxt
                              then HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
guardMName
                              else (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)
                              -- Only list/monad comprehensions use 'guard'
                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
                              -- Here "gd" is a guard

        ; (thing
thing, FreeVars
fvs3)    <- [Name] -> RnM (thing, FreeVars)
thing_inside []
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBodyStmt GhcRn GhcRn (Located (body GhcRn))
-> Located (body GhcRn)
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField Located (body GhcRn)
body' SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
guard_op), FreeVars
fv_expr)]
                  , thing
thing), FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }

rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (L SrcSpan
loc (BindStmt XBindStmt GhcPs GhcPs (Located (body GhcPs))
_ LPat GhcPs
pat Located (body GhcPs)
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { (Located (body GhcRn)
body', FreeVars
fv_expr) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
                -- The binders do not scope over the expression
        ; (SyntaxExpr GhcRn
bind_op, FreeVars
fvs1) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
bindMName

        ; (SyntaxExpr GhcRn
fail_op, FreeVars
fvs2) <- LPat GhcPs
-> HsStmtContext Name -> RnM (SyntaxExpr GhcRn, FreeVars)
monadFailOp LPat GhcPs
pat HsStmtContext Name
ctxt

        ; HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a.
HsMatchContext Name
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
ctxt) LPat GhcPs
pat ((LPat GhcRn
  -> RnM
       (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
        FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
       FreeVars))
-> (LPat GhcRn
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
pat' -> do
        { (thing
thing, FreeVars
fvs3) <- [Name] -> RnM (thing, FreeVars)
thing_inside (LPat GhcRn -> [IdP GhcRn]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcRn
pat')
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (( [( SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBindStmt GhcRn GhcRn (Located (body GhcRn))
-> LPat GhcRn
-> Located (body GhcRn)
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField LPat GhcRn
pat' Located (body GhcRn)
body' SyntaxExpr GhcRn
bind_op SyntaxExpr GhcRn
fail_op)
                     , FreeVars
fv_expr )]
                  , thing
thing),
                  FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }}
       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
        -- but it does not matter because the names are unique

rnStmt HsStmtContext Name
_ Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ (L SrcSpan
loc (LetStmt XLetStmt GhcPs GhcPs (Located (body GhcPs))
_ (L SrcSpan
l HsLocalBinds GhcPs
binds))) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn
    -> FreeVars
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn
  -> FreeVars
  -> RnM
       (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
        FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
       FreeVars))
-> (HsLocalBinds GhcRn
    -> FreeVars
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
bind_fvs -> do
        { (thing
thing, FreeVars
fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside (HsLocalBinds GhcRn -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectLocalBinders HsLocalBinds GhcRn
binds')
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLetStmt GhcRn GhcRn (Located (body GhcRn))
-> LHsLocalBinds GhcRn -> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField (SrcSpan -> HsLocalBinds GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcRn
binds')), FreeVars
bind_fvs)], thing
thing)
                 , FreeVars
fvs) }  }

rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody (L SrcSpan
loc (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [LStmt GhcPs (Located (body GhcPs))]
rec_stmts })) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { (SyntaxExpr GhcRn
return_op, FreeVars
fvs1)  <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
returnMName
        ; (SyntaxExpr GhcRn
mfix_op,   FreeVars
fvs2)  <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
mfixName
        ; (SyntaxExpr GhcRn
bind_op,   FreeVars
fvs3)  <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
bindMName
        ; let empty_rec_stmt :: StmtLR GhcRn GhcRn (Located (body GhcRn))
empty_rec_stmt = StmtLR GhcRn GhcRn (Located (body GhcRn))
forall bodyR. StmtLR GhcRn GhcRn bodyR
emptyRecStmtName { recS_ret_fn :: SyntaxExpr GhcRn
recS_ret_fn  = SyntaxExpr GhcRn
return_op
                                                , recS_mfix_fn :: SyntaxExpr GhcRn
recS_mfix_fn = SyntaxExpr GhcRn
mfix_op
                                                , recS_bind_fn :: SyntaxExpr GhcRn
recS_bind_fn = SyntaxExpr GhcRn
bind_op }

        -- Step1: Bring all the binders of the mdo into scope
        -- (Remember that this also removes the binders from the
        -- finally-returned free-vars.)
        -- And rename each individual stmt, making a
        -- singleton segment.  At this stage the FwdRefs field
        -- isn't finished: it's empty for all except a BindStmt
        -- for which it's the fwd refs within the bind itself
        -- (This set may not be empty, because we're in a recursive
        -- context.)
        ; (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (body :: * -> *) a.
Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [LStmt GhcPs (Located (body GhcPs))]
rec_stmts   (([Segment (LStmt GhcRn (Located (body GhcRn)))]
  -> RnM
       (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
        FreeVars))
 -> RnM
      (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
       FreeVars))
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
    -> RnM
         (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
          FreeVars))
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Segment (LStmt GhcRn (Located (body GhcRn)))]
segs -> do
        { let bndrs :: [Name]
bndrs = FreeVars -> [Name]
nameSetElemsStable (FreeVars -> [Name]) -> FreeVars -> [Name]
forall a b. (a -> b) -> a -> b
$
                        (Segment (LStmt GhcRn (Located (body GhcRn)))
 -> FreeVars -> FreeVars)
-> FreeVars
-> [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> FreeVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
unionNameSet (FreeVars -> FreeVars -> FreeVars)
-> (Segment (LStmt GhcRn (Located (body GhcRn))) -> FreeVars)
-> Segment (LStmt GhcRn (Located (body GhcRn)))
-> FreeVars
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(FreeVars
ds,FreeVars
_,FreeVars
_,LStmt GhcRn (Located (body GhcRn))
_) -> FreeVars
ds))
                              FreeVars
emptyNameSet
                              [Segment (LStmt GhcRn (Located (body GhcRn)))]
segs
          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
        ; (thing
thing, FreeVars
fvs_later) <- [Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs
        ; let ([LStmt GhcRn (Located (body GhcRn))]
rec_stmts', FreeVars
fvs) = SrcSpan
-> HsStmtContext Name
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> FreeVars
-> ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
forall body.
SrcSpan
-> HsStmtContext Name
-> Stmt GhcRn body
-> [Segment (LStmt GhcRn body)]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segmentRecStmts SrcSpan
loc HsStmtContext Name
ctxt StmtLR GhcRn GhcRn (Located (body GhcRn))
empty_rec_stmt [Segment (LStmt GhcRn (Located (body GhcRn)))]
segs FreeVars
fvs_later
        -- We aren't going to try to group RecStmts with
        -- ApplicativeDo, so attaching empty FVs is fine.
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( (([LStmt GhcRn (Located (body GhcRn))]
-> [FreeVars] -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LStmt GhcRn (Located (body GhcRn))]
rec_stmts' (FreeVars -> [FreeVars]
forall a. a -> [a]
repeat FreeVars
emptyNameSet)), thing
thing)
                 , FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) } }

rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ (L SrcSpan
loc (ParStmt XParStmt GhcPs GhcPs (Located (body GhcPs))
_ [ParStmtBlock GhcPs GhcPs]
segs HsExpr GhcPs
_ SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do  { (HsExpr GhcRn
mzip_op, FreeVars
fvs1)   <- HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext Name
ctxt Name
mzipName
        ; (SyntaxExpr GhcRn
bind_op, FreeVars
fvs2)   <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
bindMName
        ; (SyntaxExpr GhcRn
return_op, FreeVars
fvs3) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
returnMName
        ; (([ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs4) <- HsStmtContext Name
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall thing.
HsStmtContext Name
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts (HsStmtContext Name -> HsStmtContext Name
forall id. HsStmtContext id -> HsStmtContext id
ParStmtCtxt HsStmtContext Name
ctxt) SyntaxExpr GhcRn
return_op [ParStmtBlock GhcPs GhcPs]
segs [Name] -> RnM (thing, FreeVars)
thing_inside
        ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([(SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XParStmt GhcRn GhcRn (Located (body GhcRn))
-> [ParStmtBlock GhcRn GhcRn]
-> HsExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField [ParStmtBlock GhcRn GhcRn]
segs' HsExpr GhcRn
mzip_op SyntaxExpr GhcRn
bind_op), FreeVars
fvs4)], thing
thing)
                 , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs4) }

rnStmt HsStmtContext Name
ctxt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ (L SrcSpan
loc (TransStmt { trS_stmts :: forall idL idR body. StmtLR idL idR body -> [ExprLStmt idL]
trS_stmts = [ExprLStmt GhcPs]
stmts, trS_by :: forall idL idR body. StmtLR idL idR body -> Maybe (LHsExpr idR)
trS_by = Maybe (LHsExpr GhcPs)
by, trS_form :: forall idL idR body. StmtLR idL idR body -> TransForm
trS_form = TransForm
form
                              , trS_using :: forall idL idR body. StmtLR idL idR body -> LHsExpr idR
trS_using = LHsExpr GhcPs
using })) [Name] -> RnM (thing, FreeVars)
thing_inside
  = do { -- Rename the 'using' expression in the context before the transform is begun
         (LHsExpr GhcRn
using', FreeVars
fvs1) <- LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr LHsExpr GhcPs
using

         -- Rename the stmts and the 'by' expression
         -- Keep track of the variables mentioned in the 'by' expression
       ; (([LStmt GhcRn (LHsExpr GhcRn)]
stmts', (Maybe (LHsExpr GhcRn)
by', [Name]
used_bndrs, thing
thing)), FreeVars
fvs2)
             <- HsStmtContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> [ExprLStmt GhcPs]
-> ([Name]
    -> RnM ((Maybe (LHsExpr GhcRn), [Name], thing), FreeVars))
-> RnM
     (([LStmt GhcRn (LHsExpr GhcRn)],
       (Maybe (LHsExpr GhcRn), [Name], thing)),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts (HsStmtContext Name -> HsStmtContext Name
forall id. HsStmtContext id -> HsStmtContext id
TransStmtCtxt HsStmtContext Name
ctxt) LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr [ExprLStmt GhcPs]
stmts (([Name] -> RnM ((Maybe (LHsExpr GhcRn), [Name], thing), FreeVars))
 -> RnM
      (([LStmt GhcRn (LHsExpr GhcRn)],
        (Maybe (LHsExpr GhcRn), [Name], thing)),
       FreeVars))
-> ([Name]
    -> RnM ((Maybe (LHsExpr GhcRn), [Name], thing), FreeVars))
-> RnM
     (([LStmt GhcRn (LHsExpr GhcRn)],
       (Maybe (LHsExpr GhcRn), [Name], thing)),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs ->
                do { (Maybe (LHsExpr GhcRn)
by',   FreeVars
fvs_by) <- (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> Maybe (LHsExpr GhcPs) -> RnM (Maybe (LHsExpr GhcRn), FreeVars)
forall a b.
(a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr Maybe (LHsExpr GhcPs)
by
                   ; (thing
thing, FreeVars
fvs_thing) <- [Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs
                   ; let fvs :: FreeVars
fvs = FreeVars
fvs_by FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_thing
                         used_bndrs :: [Name]
used_bndrs = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
                         -- The paper (Fig 5) has a bug here; we must treat any free variable
                         -- of the "thing inside", **or of the by-expression**, as used
                   ; ((Maybe (LHsExpr GhcRn), [Name], thing), FreeVars)
-> RnM ((Maybe (LHsExpr GhcRn), [Name], thing), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (LHsExpr GhcRn)
by', [Name]
used_bndrs, thing
thing), FreeVars
fvs) }

       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
       ; (SyntaxExpr GhcRn
return_op, FreeVars
fvs3) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
returnMName
       ; (SyntaxExpr GhcRn
bind_op,   FreeVars
fvs4) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
bindMName
       ; (HsExpr GhcRn
fmap_op,   FreeVars
fvs5) <- case TransForm
form of
                                TransForm
ThenForm -> (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p)
noExpr, FreeVars
emptyFVs)
                                TransForm
_        -> HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext Name
ctxt Name
fmapName

       ; let all_fvs :: FreeVars
all_fvs  = FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3
                             FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs4 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs5
             bndr_map :: [(Name, Name)]
bndr_map = [Name]
used_bndrs [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
used_bndrs
             -- See Note [TransStmt binder map] in GHC.Hs.Expr

       ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnStmt: implicitly rebound these used binders:" ([(Name, Name)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [(Name, Name)]
bndr_map)
       ; (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
 FreeVars)
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([(SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TransStmt :: forall idL idR body.
XTransStmt idL idR body
-> TransForm
-> [ExprLStmt idL]
-> [(IdP idR, IdP idR)]
-> LHsExpr idR
-> Maybe (LHsExpr idR)
-> SyntaxExpr idR
-> SyntaxExpr idR
-> HsExpr idR
-> StmtLR idL idR body
TransStmt { trS_ext :: XTransStmt GhcRn GhcRn (Located (body GhcRn))
trS_ext = XTransStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField
                                    , trS_stmts :: [LStmt GhcRn (LHsExpr GhcRn)]
trS_stmts = [LStmt GhcRn (LHsExpr GhcRn)]
stmts', trS_bndrs :: [(IdP GhcRn, IdP GhcRn)]
trS_bndrs = [(Name, Name)]
[(IdP GhcRn, IdP GhcRn)]
bndr_map
                                    , trS_by :: Maybe (LHsExpr GhcRn)
trS_by = Maybe (LHsExpr GhcRn)
by', trS_using :: LHsExpr GhcRn
trS_using = LHsExpr GhcRn
using', trS_form :: TransForm
trS_form = TransForm
form
                                    , trS_ret :: SyntaxExpr GhcRn
trS_ret = SyntaxExpr GhcRn
return_op, trS_bind :: SyntaxExpr GhcRn
trS_bind = SyntaxExpr GhcRn
bind_op
                                    , trS_fmap :: HsExpr GhcRn
trS_fmap = HsExpr GhcRn
fmap_op }), FreeVars
fvs2)], thing
thing), FreeVars
all_fvs) }

rnStmt HsStmtContext Name
_ Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ (L SrcSpan
_ ApplicativeStmt{}) [Name] -> RnM (thing, FreeVars)
_ =
  String
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a. String -> a
panic String
"rnStmt: ApplicativeStmt"

rnStmt HsStmtContext Name
_ Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ (L SrcSpan
_ (XStmtLR XXStmtLR GhcPs GhcPs (Located (body GhcPs))
nec)) [Name] -> RnM (thing, FreeVars)
_ =
  NoExtCon
-> RnM
     (([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing),
      FreeVars)
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcPs GhcPs (Located (body GhcPs))
NoExtCon
nec

rnParallelStmts :: forall thing. HsStmtContext Name
                -> SyntaxExpr GhcRn
                -> [ParStmtBlock GhcPs GhcPs]
                -> ([Name] -> RnM (thing, FreeVars))
                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-- Note [Renaming parallel Stmts]
rnParallelStmts :: HsStmtContext Name
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts HsStmtContext Name
ctxt SyntaxExpr GhcRn
return_op [ParStmtBlock GhcPs GhcPs]
segs [Name] -> RnM (thing, FreeVars)
thing_inside
  = do { LocalRdrEnv
orig_lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs LocalRdrEnv
orig_lcl_env [] [ParStmtBlock GhcPs GhcPs]
segs }
  where
    rn_segs :: LocalRdrEnv
            -> [Name] -> [ParStmtBlock GhcPs GhcPs]
            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
    rn_segs :: LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs LocalRdrEnv
_ [Name]
bndrs_so_far []
      = do { let ([Name]
bndrs', [NonEmpty Name]
dups) = (Name -> Name -> Ordering) -> [Name] -> ([Name], [NonEmpty Name])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Name -> Name -> Ordering
cmpByOcc [Name]
bndrs_so_far
           ; (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
Outputable a =>
NonEmpty a -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr [NonEmpty Name]
dups
           ; (thing
thing, FreeVars
fvs) <- [Name] -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs' ([Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs')
           ; (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([], thing
thing), FreeVars
fvs) }

    rn_segs LocalRdrEnv
env [Name]
bndrs_so_far (ParStmtBlock XParStmtBlock GhcPs GhcPs
x [ExprLStmt GhcPs]
stmts [IdP GhcPs]
_ SyntaxExpr GhcPs
_ : [ParStmtBlock GhcPs GhcPs]
segs)
      = do { (([LStmt GhcRn (LHsExpr GhcRn)]
stmts', ([Name]
used_bndrs, [ParStmtBlock GhcRn GhcRn]
segs', thing
thing)), FreeVars
fvs)
                    <- HsStmtContext Name
-> (LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars))
-> [ExprLStmt GhcPs]
-> ([Name]
    -> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> RnM
     (([LStmt GhcRn (LHsExpr GhcRn)],
       ([Name], [ParStmtBlock GhcRn GhcRn], thing)),
      FreeVars)
forall (body :: * -> *) thing.
Outputable (body GhcPs) =>
HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext Name
ctxt LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr [ExprLStmt GhcPs]
stmts (([Name]
  -> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
 -> RnM
      (([LStmt GhcRn (LHsExpr GhcRn)],
        ([Name], [ParStmtBlock GhcRn GhcRn], thing)),
       FreeVars))
-> ([Name]
    -> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> RnM
     (([LStmt GhcRn (LHsExpr GhcRn)],
       ([Name], [ParStmtBlock GhcRn GhcRn], thing)),
      FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs ->
                       LocalRdrEnv
-> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
env       (RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
 -> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall a b. (a -> b) -> a -> b
$ do
                       { (([ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs) <- LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs LocalRdrEnv
env ([Name]
bndrs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bndrs_so_far) [ParStmtBlock GhcPs GhcPs]
segs
                       ; let used_bndrs :: [Name]
used_bndrs = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
                       ; (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> RnM (([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Name]
used_bndrs, [ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs) }

           ; let seg' :: ParStmtBlock GhcRn GhcRn
seg' = XParStmtBlock GhcRn GhcRn
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> [IdP GhcRn]
-> SyntaxExpr GhcRn
-> ParStmtBlock GhcRn GhcRn
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcPs GhcPs
XParStmtBlock GhcRn GhcRn
x [LStmt GhcRn (LHsExpr GhcRn)]
stmts' [Name]
[IdP GhcRn]
used_bndrs SyntaxExpr GhcRn
return_op
           ; (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ParStmtBlock GhcRn GhcRn
seg'ParStmtBlock GhcRn GhcRn
-> [ParStmtBlock GhcRn GhcRn] -> [ParStmtBlock GhcRn GhcRn]
forall a. a -> [a] -> [a]
:[ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs) }
    rn_segs LocalRdrEnv
_ [Name]
_ (XParStmtBlock XXParStmtBlock GhcPs GhcPs
nec:[ParStmtBlock GhcPs GhcPs]
_) = NoExtCon -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall a. NoExtCon -> a
noExtCon XXParStmtBlock GhcPs GhcPs
NoExtCon
nec

    cmpByOcc :: Name -> Name -> Ordering
cmpByOcc Name
n1 Name
n2 = Name -> OccName
nameOccName Name
n1 OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
nameOccName Name
n2
    dupErr :: NonEmpty a -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr NonEmpty a
vs = MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (String -> MsgDoc
text String
"Duplicate binding in parallel list comprehension for:"
                    MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head NonEmpty a
vs)))

lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntaxName, but respects contexts
lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
n
  | HsStmtContext Name -> Bool
rebindableContext HsStmtContext Name
ctxt
  = Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
n
  | Bool
otherwise
  = (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
n, FreeVars
emptyFVs)

lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext Name
ctxt Name
name
  | HsStmtContext Name -> Bool
rebindableContext HsStmtContext Name
ctxt
  = do { Bool
rebindable_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RebindableSyntax
       ; if Bool
rebindable_on
         then do { Name
fm <- RdrName -> RnM Name
lookupOccRn (Name -> RdrName
nameRdrName Name
name)
                 ; (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (Located Name)
fm), Name -> FreeVars
unitFV Name
fm) }
         else RnM (HsExpr GhcRn, FreeVars)
not_rebindable }
  | Bool
otherwise
  = RnM (HsExpr GhcRn, FreeVars)
not_rebindable
  where
    not_rebindable :: RnM (HsExpr GhcRn, FreeVars)
not_rebindable = (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (Located Name)
name), FreeVars
emptyFVs)

-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in DsArrows
rebindableContext :: HsStmtContext Name -> Bool
rebindableContext :: HsStmtContext Name -> Bool
rebindableContext HsStmtContext Name
ctxt = case HsStmtContext Name
ctxt of
  HsStmtContext Name
ListComp        -> Bool
False
  HsStmtContext Name
ArrowExpr       -> Bool
False
  PatGuard {}     -> Bool
False

  HsStmtContext Name
DoExpr          -> Bool
True
  HsStmtContext Name
MDoExpr         -> Bool
True
  HsStmtContext Name
MonadComp       -> Bool
True
  HsStmtContext Name
GhciStmtCtxt    -> Bool
True   -- I suppose?

  ParStmtCtxt   HsStmtContext Name
c -> HsStmtContext Name -> Bool
rebindableContext HsStmtContext Name
c     -- Look inside to
  TransStmtCtxt HsStmtContext Name
c -> HsStmtContext Name -> Bool
rebindableContext HsStmtContext Name
c     -- the parent context

{-
Note [Renaming parallel Stmts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Renaming parallel statements is painful.  Given, say
     [ a+c | a <- as, bs <- bss
           | c <- bs, a <- ds ]
Note that
  (a) In order to report "Defined but not used" about 'bs', we must
      rename each group of Stmts with a thing_inside whose FreeVars
      include at least {a,c}

  (b) We want to report that 'a' is illegally bound in both branches

  (c) The 'bs' in the second group must obviously not be captured by
      the binding in the first group

To satisfy (a) we nest the segements.
To satisfy (b) we check for duplicates just before thing_inside.
To satisfy (c) we reset the LocalRdrEnv each time.

************************************************************************
*                                                                      *
\subsubsection{mdo expressions}
*                                                                      *
************************************************************************
-}

type FwdRefs = NameSet
type Segment stmts = (Defs,
                      Uses,     -- May include defs
                      FwdRefs,  -- A subset of uses that are
                                --   (a) used before they are bound in this segment, or
                                --   (b) used here, and bound in subsequent segments
                      stmts)    -- Either Stmt or [Stmt]


-- wrapper that does both the left- and right-hand sides
rnRecStmtsAndThen :: Outputable (body GhcPs) =>
                     (Located (body GhcPs)
                  -> RnM (Located (body GhcRn), FreeVars))
                  -> [LStmt GhcPs (Located (body GhcPs))]
                         -- assumes that the FreeVars returned includes
                         -- the FreeVars of the Segments
                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
                      -> RnM (a, FreeVars))
                  -> RnM (a, FreeVars)
rnRecStmtsAndThen :: (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
    -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [LStmt GhcPs (Located (body GhcPs))]
s [Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)
cont
  = do  { -- (A) Make the mini fixity env for all of the stmts
          MiniFixityEnv
fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv ([LStmt GhcPs (Located (body GhcPs))] -> [LFixitySig GhcPs]
forall body. [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmt GhcPs (Located (body GhcPs))]
s)

          -- (B) Do the LHSes
        ; [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
new_lhs_and_fv <- MiniFixityEnv
-> [LStmt GhcPs (Located (body GhcPs))]
-> RnM [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
forall body.
Outputable body =>
MiniFixityEnv
-> [LStmt GhcPs body] -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [LStmt GhcPs (Located (body GhcPs))]
s

          --    ...bring them and their fixities into scope
        ; let bound_names :: [IdP GhcRn]
bound_names = [LStmtLR GhcRn GhcPs (Located (body GhcPs))] -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
[LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]
collectLStmtsBinders (((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
 -> LStmtLR GhcRn GhcPs (Located (body GhcPs)))
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> [LStmtLR GhcRn GhcPs (Located (body GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> LStmtLR GhcRn GhcPs (Located (body GhcPs))
forall a b. (a, b) -> a
fst [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
new_lhs_and_fv)
              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
              rec_uses :: [(SrcSpan, [Name])]
rec_uses = [LStmtLR GhcRn GhcPs (Located (body GhcPs))] -> [(SrcSpan, [Name])]
forall (idR :: Pass) (body :: * -> *).
[LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
-> [(SrcSpan, [Name])]
lStmtsImplicits (((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
 -> LStmtLR GhcRn GhcPs (Located (body GhcPs)))
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> [LStmtLR GhcRn GhcPs (Located (body GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> LStmtLR GhcRn GhcPs (Located (body GhcPs))
forall a b. (a, b) -> a
fst [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
new_lhs_and_fv)
              implicit_uses :: FreeVars
implicit_uses = [Name] -> FreeVars
mkNameSet ([Name] -> FreeVars) -> [Name] -> FreeVars
forall a b. (a -> b) -> a -> b
$ ((SrcSpan, [Name]) -> [Name]) -> [(SrcSpan, [Name])] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SrcSpan, [Name]) -> [Name]
forall a b. (a, b) -> b
snd ([(SrcSpan, [Name])] -> [Name]) -> [(SrcSpan, [Name])] -> [Name]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, [Name])]
rec_uses
        ; [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
[IdP GhcRn]
bound_names (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
          MiniFixityEnv -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
fix_env [Name]
[IdP GhcRn]
bound_names (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ do

          -- (C) do the right-hand-sides and thing-inside
        { [Segment (LStmt GhcRn (Located (body GhcRn)))]
segs <- (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (body :: * -> *).
Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmts Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
[IdP GhcRn]
bound_names [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
new_lhs_and_fv
        ; (a
res, FreeVars
fvs) <- [Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)
cont [Segment (LStmt GhcRn (Located (body GhcRn)))]
segs
        ; ((SrcSpan, [Name]) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(SrcSpan, [Name])] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SrcSpan
loc, [Name]
ns) -> SrcSpan
-> FreeVars -> Maybe [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
fvs ([Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
ns))
                [(SrcSpan, [Name])]
rec_uses
        ; [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedLocalBinds [Name]
[IdP GhcRn]
bound_names (FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
implicit_uses)
        ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, FreeVars
fvs) }}

-- get all the fixity decls in any Let stmt
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmtLR GhcPs GhcPs body]
l =
    (LStmtLR GhcPs GhcPs body
 -> [LFixitySig GhcPs] -> [LFixitySig GhcPs])
-> [LFixitySig GhcPs]
-> [LStmtLR GhcPs GhcPs body]
-> [LFixitySig GhcPs]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ LStmtLR GhcPs GhcPs body
s -> \[LFixitySig GhcPs]
acc -> case LStmtLR GhcPs GhcPs body
s of
            (L SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs body
_ (L SrcSpan
_ (HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
_ [LSig GhcPs]
sigs))))) ->
              (LSig GhcPs -> [LFixitySig GhcPs] -> [LFixitySig GhcPs])
-> [LFixitySig GhcPs] -> [LSig GhcPs] -> [LFixitySig GhcPs]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ LSig GhcPs
sig -> \ [LFixitySig GhcPs]
acc -> case LSig GhcPs
sig of
                                         (L SrcSpan
loc (FixSig XFixSig GhcPs
_ FixitySig GhcPs
s)) -> (SrcSpan -> FixitySig GhcPs -> LFixitySig GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FixitySig GhcPs
s) LFixitySig GhcPs -> [LFixitySig GhcPs] -> [LFixitySig GhcPs]
forall a. a -> [a] -> [a]
: [LFixitySig GhcPs]
acc
                                         LSig GhcPs
_ -> [LFixitySig GhcPs]
acc) [LFixitySig GhcPs]
acc [LSig GhcPs]
sigs
            LStmtLR GhcPs GhcPs body
_ -> [LFixitySig GhcPs]
acc) [] [LStmtLR GhcPs GhcPs body]
l

-- left-hand sides

rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
                -> LStmt GhcPs body
                   -- rename LHS, and return its FVs
                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,
                   -- so we don't bother to compute it accurately in the other cases
                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]

rn_rec_stmt_lhs :: MiniFixityEnv
-> LStmt GhcPs body -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
loc (BodyStmt XBodyStmt GhcPs GhcPs body
_ body
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b))
  = [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan -> StmtLR GhcRn GhcPs body -> LStmtLR GhcRn GhcPs body
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBodyStmt GhcRn GhcPs body
-> body
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcRn GhcPs body
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcPs body
NoExtField
noExtField body
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b), FreeVars
emptyFVs)]

rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
loc (LastStmt XLastStmt GhcPs GhcPs body
_ body
body Bool
noret SyntaxExpr GhcPs
a))
  = [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan -> StmtLR GhcRn GhcPs body -> LStmtLR GhcRn GhcPs body
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLastStmt GhcRn GhcPs body
-> body -> Bool -> SyntaxExpr GhcPs -> StmtLR GhcRn GhcPs body
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcPs body
NoExtField
noExtField body
body Bool
noret SyntaxExpr GhcPs
a), FreeVars
emptyFVs)]

rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpan
loc (BindStmt XBindStmt GhcPs GhcPs body
_ LPat GhcPs
pat body
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b))
  = do
      -- should the ctxt be MDo instead?
      (Located (Pat GhcRn)
pat', FreeVars
fv_pat) <- NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, FreeVars)
rnBindPat (MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env) LPat GhcPs
pat
      [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan -> StmtLR GhcRn GhcPs body -> LStmtLR GhcRn GhcPs body
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBindStmt GhcRn GhcPs body
-> LPat GhcRn
-> body
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcRn GhcPs body
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcRn GhcPs body
NoExtField
noExtField Located (Pat GhcRn)
LPat GhcRn
pat' body
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b), FreeVars
fv_pat)]

rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs body
_ (L SrcSpan
_ binds :: HsLocalBinds GhcPs
binds@(HsIPBinds {}))))
  = MsgDoc -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. MsgDoc -> TcRn a
failWith (MsgDoc -> HsLocalBinds GhcPs -> MsgDoc
forall a. Outputable a => MsgDoc -> a -> MsgDoc
badIpBinds (String -> MsgDoc
text String
"an mdo expression") HsLocalBinds GhcPs
binds)

rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpan
loc (LetStmt XLetStmt GhcPs GhcPs body
_ (L SrcSpan
l (HsValBinds XHsValBinds GhcPs GhcPs
x HsValBindsLR GhcPs GhcPs
binds))))
    = do ([Name]
_bound_names, HsValBindsLR GhcRn GhcPs
binds') <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
fix_env HsValBindsLR GhcPs GhcPs
binds
         [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpan -> StmtLR GhcRn GhcPs body -> LStmtLR GhcRn GhcPs body
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLetStmt GhcRn GhcPs body
-> LHsLocalBindsLR GhcRn GhcPs -> StmtLR GhcRn GhcPs body
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcPs body
NoExtField
noExtField (SrcSpan
-> HsLocalBindsLR GhcRn GhcPs -> LHsLocalBindsLR GhcRn GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XHsValBinds GhcRn GhcPs
-> HsValBindsLR GhcRn GhcPs -> HsLocalBindsLR GhcRn GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
XHsValBinds GhcRn GhcPs
x HsValBindsLR GhcRn GhcPs
binds'))),
                 -- Warning: this is bogus; see function invariant
                 FreeVars
emptyFVs
                 )]

-- XXX Do we need to do something with the return and mfix names?
rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpan
_ (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [LStmt GhcPs body]
stmts }))  -- Flatten Rec inside Rec
    = MiniFixityEnv
-> [LStmt GhcPs body] -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall body.
Outputable body =>
MiniFixityEnv
-> [LStmt GhcPs body] -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [LStmt GhcPs body]
stmts

rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs body
stmt@(L SrcSpan
_ (ParStmt {}))       -- Syntactically illegal in mdo
  = String -> MsgDoc -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt" (LStmt GhcPs body -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LStmt GhcPs body
stmt)

rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs body
stmt@(L SrcSpan
_ (TransStmt {}))     -- Syntactically illegal in mdo
  = String -> MsgDoc -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt" (LStmt GhcPs body -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LStmt GhcPs body
stmt)

rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs body
stmt@(L SrcSpan
_ (ApplicativeStmt {})) -- Shouldn't appear yet
  = String -> MsgDoc -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt" (LStmt GhcPs body -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LStmt GhcPs body
stmt)

rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs body
_ (L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_))))
  = String -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. String -> a
panic String
"rn_rec_stmt LetStmt EmptyLocalBinds"
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
_ (LetStmt XLetStmt GhcPs GhcPs body
_ (L SrcSpan
_ (XHsLocalBindsLR XXHsLocalBindsLR GhcPs GhcPs
nec))))
  = NoExtCon -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. NoExtCon -> a
noExtCon XXHsLocalBindsLR GhcPs GhcPs
NoExtCon
nec
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpan
_ (XStmtLR XXStmtLR GhcPs GhcPs body
nec))
  = NoExtCon -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcPs GhcPs body
NoExtCon
nec

rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
                 -> [LStmt GhcPs body]
                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmts_lhs :: MiniFixityEnv
-> [LStmt GhcPs body] -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [LStmt GhcPs body]
stmts
  = do { [(LStmtLR GhcRn GhcPs body, FreeVars)]
ls <- (LStmt GhcPs body -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)])
-> [LStmt GhcPs body] -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (MiniFixityEnv
-> LStmt GhcPs body -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall body.
Outputable body =>
MiniFixityEnv
-> LStmt GhcPs body -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmt_lhs MiniFixityEnv
fix_env) [LStmt GhcPs body]
stmts
       ; let boundNames :: [IdP GhcRn]
boundNames = [LStmtLR GhcRn GhcPs body] -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
[LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]
collectLStmtsBinders (((LStmtLR GhcRn GhcPs body, FreeVars) -> LStmtLR GhcRn GhcPs body)
-> [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> [LStmtLR GhcRn GhcPs body]
forall a b. (a -> b) -> [a] -> [b]
map (LStmtLR GhcRn GhcPs body, FreeVars) -> LStmtLR GhcRn GhcPs body
forall a b. (a, b) -> a
fst [(LStmtLR GhcRn GhcPs body, FreeVars)]
ls)
            -- First do error checking: we need to check for dups here because we
            -- don't bind all of the variables from the Stmt at once
            -- with bindLocatedLocals.
       ; [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupNames [Name]
[IdP GhcRn]
boundNames
       ; [(LStmtLR GhcRn GhcPs body, FreeVars)]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(LStmtLR GhcRn GhcPs body, FreeVars)]
ls }


-- right-hand-sides

rn_rec_stmt :: (Outputable (body GhcPs)) =>
               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
            -> [Name]
            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
        -- Rename a Stmt that is inside a RecStmt (or mdo)
        -- Assumes all binders are already in scope
        -- Turns each stmt into a singleton Stmt
rn_rec_stmt :: (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
_ (L SrcSpan
loc (LastStmt XLastStmt GhcRn GhcPs (Located (body GhcPs))
_ Located (body GhcPs)
body Bool
noret SyntaxExpr GhcPs
_), FreeVars
_)
  = do  { (Located (body GhcRn)
body', FreeVars
fv_expr) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
        ; (SyntaxExpr GhcRn
ret_op, FreeVars
fvs1)   <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
returnMName
        ; [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
emptyNameSet, FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1, FreeVars
emptyNameSet,
                   SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLastStmt GhcRn GhcRn (Located (body GhcRn))
-> Located (body GhcRn)
-> Bool
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField Located (body GhcRn)
body' Bool
noret SyntaxExpr GhcRn
ret_op))] }

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
_ (L SrcSpan
loc (BodyStmt XBodyStmt GhcRn GhcPs (Located (body GhcPs))
_ Located (body GhcPs)
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_), FreeVars
_)
  = do { (Located (body GhcRn)
body', FreeVars
fvs) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
       ; (SyntaxExpr GhcRn
then_op, FreeVars
fvs1) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
thenMName
       ; [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
emptyNameSet, FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1, FreeVars
emptyNameSet,
                 SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBodyStmt GhcRn GhcRn (Located (body GhcRn))
-> Located (body GhcRn)
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField Located (body GhcRn)
body' SyntaxExpr GhcRn
then_op SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr))] }

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
_ (L SrcSpan
loc (BindStmt XBindStmt GhcRn GhcPs (Located (body GhcPs))
_ LPat GhcRn
pat' Located (body GhcPs)
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_), FreeVars
fv_pat)
  = do { (Located (body GhcRn)
body', FreeVars
fv_expr) <- Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody Located (body GhcPs)
body
       ; (SyntaxExpr GhcRn
bind_op, FreeVars
fvs1) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
bindMName

       ; (SyntaxExpr GhcRn
fail_op, FreeVars
fvs2) <- RnM (SyntaxExpr GhcRn, FreeVars)
getMonadFailOp

       ; let bndrs :: FreeVars
bndrs = [Name] -> FreeVars
mkNameSet (LPat GhcRn -> [IdP GhcRn]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat GhcRn
pat')
             fvs :: FreeVars
fvs   = FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_pat FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2
       ; [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
bndrs, FreeVars
fvs, FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs,
                  SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XBindStmt GhcRn GhcRn (Located (body GhcRn))
-> LPat GhcRn
-> Located (body GhcRn)
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField LPat GhcRn
pat' Located (body GhcRn)
body' SyntaxExpr GhcRn
bind_op SyntaxExpr GhcRn
fail_op))] }

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ (L SrcSpan
_ (LetStmt XLetStmt GhcRn GhcPs (Located (body GhcPs))
_ (L SrcSpan
_ binds :: HsLocalBindsLR GhcRn GhcPs
binds@(HsIPBinds {}))), FreeVars
_)
  = MsgDoc -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. MsgDoc -> TcRn a
failWith (MsgDoc -> HsLocalBindsLR GhcRn GhcPs -> MsgDoc
forall a. Outputable a => MsgDoc -> a -> MsgDoc
badIpBinds (String -> MsgDoc
text String
"an mdo expression") HsLocalBindsLR GhcRn GhcPs
binds)

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
all_bndrs (L SrcSpan
loc (LetStmt XLetStmt GhcRn GhcPs (Located (body GhcPs))
_ (L SrcSpan
l (HsValBinds XHsValBinds GhcRn GhcPs
x HsValBindsLR GhcRn GhcPs
binds'))), FreeVars
_)
  = do { (HsValBinds GhcRn
binds', DefUses
du_binds) <- FreeVars
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> FreeVars
mkNameSet [Name]
all_bndrs) HsValBindsLR GhcRn GhcPs
binds'
           -- fixities and unused are handled above in rnRecStmtsAndThen
       ; let fvs :: FreeVars
fvs = DefUses -> FreeVars
allUses DefUses
du_binds
       ; [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(DefUses -> FreeVars
duDefs DefUses
du_binds, FreeVars
fvs, FreeVars
emptyNameSet,
                 SrcSpan
-> StmtLR GhcRn GhcRn (Located (body GhcRn))
-> LStmt GhcRn (Located (body GhcRn))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLetStmt GhcRn GhcRn (Located (body GhcRn))
-> LHsLocalBinds GhcRn -> StmtLR GhcRn GhcRn (Located (body GhcRn))
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcRn GhcRn (Located (body GhcRn))
NoExtField
noExtField (SrcSpan -> HsLocalBinds GhcRn -> LHsLocalBinds GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (XHsValBinds GhcRn GhcRn -> HsValBinds GhcRn -> HsLocalBinds GhcRn
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcPs
XHsValBinds GhcRn GhcRn
x HsValBinds GhcRn
binds'))))] }

-- no RecStmt case because they get flattened above when doing the LHSes
rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt@(L SrcSpan
_ (RecStmt {}), FreeVars
_)
  = String
-> MsgDoc -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt: RecStmt" ((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt)

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt@(L SrcSpan
_ (ParStmt {}), FreeVars
_)       -- Syntactically illegal in mdo
  = String
-> MsgDoc -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt: ParStmt" ((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt)

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt@(L SrcSpan
_ (TransStmt {}), FreeVars
_)     -- Syntactically illegal in mdo
  = String
-> MsgDoc -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt: TransStmt" ((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt)

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ (L SrcSpan
_ (LetStmt XLetStmt GhcRn GhcPs (Located (body GhcPs))
_ (L SrcSpan
_ (XHsLocalBindsLR XXHsLocalBindsLR GhcRn GhcPs
nec))), FreeVars
_)
  = NoExtCon -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. NoExtCon -> a
noExtCon XXHsLocalBindsLR GhcRn GhcPs
NoExtCon
nec

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ (L SrcSpan
_ (LetStmt XLetStmt GhcRn GhcPs (Located (body GhcPs))
_ (L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcPs
_))), FreeVars
_)
  = String -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. String -> a
panic String
"rn_rec_stmt: LetStmt EmptyLocalBinds"

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt@(L SrcSpan
_ (ApplicativeStmt {}), FreeVars
_)
  = String
-> MsgDoc -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"rn_rec_stmt: ApplicativeStmt" ((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
stmt)

rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
_ [Name]
_ (L SrcSpan
_ (XStmtLR XXStmtLR GhcRn GhcPs (Located (body GhcPs))
nec), FreeVars
_)
  = NoExtCon -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcRn GhcPs (Located (body GhcPs))
NoExtCon
nec

rn_rec_stmts :: Outputable (body GhcPs) =>
                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
             -> [Name]
             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmts :: (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmts Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
bndrs [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
stmts
  = do { [[Segment (LStmt GhcRn (Located (body GhcRn)))]]
segs_s <- ((LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
 -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))])
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [[Segment (LStmt GhcRn (Located (body GhcRn)))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (body :: * -> *).
Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmt Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)
rnBody [Name]
bndrs) [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
stmts
       ; [Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Segment (LStmt GhcRn (Located (body GhcRn)))]]
-> [Segment (LStmt GhcRn (Located (body GhcRn)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Segment (LStmt GhcRn (Located (body GhcRn)))]]
segs_s) }

---------------------------------------------
segmentRecStmts :: SrcSpan -> HsStmtContext Name
                -> Stmt GhcRn body
                -> [Segment (LStmt GhcRn body)] -> FreeVars
                -> ([LStmt GhcRn body], FreeVars)

segmentRecStmts :: SrcSpan
-> HsStmtContext Name
-> Stmt GhcRn body
-> [Segment (LStmt GhcRn body)]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segmentRecStmts SrcSpan
loc HsStmtContext Name
ctxt Stmt GhcRn body
empty_rec_stmt [Segment (LStmt GhcRn body)]
segs FreeVars
fvs_later
  | [Segment (LStmt GhcRn body)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Segment (LStmt GhcRn body)]
segs
  = ([], FreeVars
fvs_later)

  | HsStmtContext Name
MDoExpr <- HsStmtContext Name
ctxt
  = Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
forall body.
Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segsToStmts Stmt GhcRn body
empty_rec_stmt [Segment [LStmt GhcRn body]]
grouped_segs FreeVars
fvs_later
               -- Step 4: Turn the segments into Stmts
                --         Use RecStmt when and only when there are fwd refs
                --         Also gather up the uses from the end towards the
                --         start, so we can tell the RecStmt which things are
                --         used 'after' the RecStmt

  | Bool
otherwise
  = ([ SrcSpan -> Stmt GhcRn body -> LStmt GhcRn body
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Stmt GhcRn body -> LStmt GhcRn body)
-> Stmt GhcRn body -> LStmt GhcRn body
forall a b. (a -> b) -> a -> b
$
       Stmt GhcRn body
empty_rec_stmt { recS_stmts :: [LStmt GhcRn body]
recS_stmts = [LStmt GhcRn body]
ss
                      , recS_later_ids :: [IdP GhcRn]
recS_later_ids = FreeVars -> [Name]
nameSetElemsStable
                                           (FreeVars
defs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs_later)
                      , recS_rec_ids :: [IdP GhcRn]
recS_rec_ids   = FreeVars -> [Name]
nameSetElemsStable
                                           (FreeVars
defs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
uses) }]
          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
    , FreeVars
uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_later)

  where
    ([FreeVars]
defs_s, [FreeVars]
uses_s, [FreeVars]
_, [LStmt GhcRn body]
ss) = [Segment (LStmt GhcRn body)]
-> ([FreeVars], [FreeVars], [FreeVars], [LStmt GhcRn body])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [Segment (LStmt GhcRn body)]
segs
    defs :: FreeVars
defs = [FreeVars] -> FreeVars
plusFVs [FreeVars]
defs_s
    uses :: FreeVars
uses = [FreeVars] -> FreeVars
plusFVs [FreeVars]
uses_s

                -- Step 2: Fill in the fwd refs.
                --         The segments are all singletons, but their fwd-ref
                --         field mentions all the things used by the segment
                --         that are bound after their use
    segs_w_fwd_refs :: [Segment (LStmt GhcRn body)]
segs_w_fwd_refs = [Segment (LStmt GhcRn body)] -> [Segment (LStmt GhcRn body)]
forall a. [Segment a] -> [Segment a]
addFwdRefs [Segment (LStmt GhcRn body)]
segs

                -- Step 3: Group together the segments to make bigger segments
                --         Invariant: in the result, no segment uses a variable
                --                    bound in a later segment
    grouped_segs :: [Segment [LStmt GhcRn body]]
grouped_segs = HsStmtContext Name
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
forall body.
HsStmtContext Name
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext Name
ctxt [Segment (LStmt GhcRn body)]
segs_w_fwd_refs

----------------------------
addFwdRefs :: [Segment a] -> [Segment a]
-- So far the segments only have forward refs *within* the Stmt
--      (which happens for bind:  x <- ...x...)
-- This function adds the cross-seg fwd ref info

addFwdRefs :: [Segment a] -> [Segment a]
addFwdRefs [Segment a]
segs
  = ([Segment a], FreeVars) -> [Segment a]
forall a b. (a, b) -> a
fst ((Segment a -> ([Segment a], FreeVars) -> ([Segment a], FreeVars))
-> ([Segment a], FreeVars)
-> [Segment a]
-> ([Segment a], FreeVars)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Segment a -> ([Segment a], FreeVars) -> ([Segment a], FreeVars)
forall d.
(FreeVars, FreeVars, FreeVars, d)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
mk_seg ([], FreeVars
emptyNameSet) [Segment a]
segs)
  where
    mk_seg :: (FreeVars, FreeVars, FreeVars, d)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
mk_seg (FreeVars
defs, FreeVars
uses, FreeVars
fwds, d
stmts) ([(FreeVars, FreeVars, FreeVars, d)]
segs, FreeVars
later_defs)
        = ((FreeVars, FreeVars, FreeVars, d)
new_seg (FreeVars, FreeVars, FreeVars, d)
-> [(FreeVars, FreeVars, FreeVars, d)]
-> [(FreeVars, FreeVars, FreeVars, d)]
forall a. a -> [a] -> [a]
: [(FreeVars, FreeVars, FreeVars, d)]
segs, FreeVars
all_defs)
        where
          new_seg :: (FreeVars, FreeVars, FreeVars, d)
new_seg = (FreeVars
defs, FreeVars
uses, FreeVars
new_fwds, d
stmts)
          all_defs :: FreeVars
all_defs = FreeVars
later_defs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
defs
          new_fwds :: FreeVars
new_fwds = FreeVars
fwds FreeVars -> FreeVars -> FreeVars
`unionNameSet` (FreeVars
uses FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
later_defs)
                -- Add the downstream fwd refs here

{-
Note [Segmenting mdo]
~~~~~~~~~~~~~~~~~~~~~
NB. June 7 2012: We only glom segments that appear in an explicit mdo;
and leave those found in "do rec"'s intact.  See
https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion
leading to this design choice.  Hence the test in segmentRecStmts.

Note [Glomming segments]
~~~~~~~~~~~~~~~~~~~~~~~~
Glomming the singleton segments of an mdo into minimal recursive groups.

At first I thought this was just strongly connected components, but
there's an important constraint: the order of the stmts must not change.

Consider
     mdo { x <- ...y...
           p <- z
           y <- ...x...
           q <- x
           z <- y
           r <- x }

Here, the first stmt mention 'y', which is bound in the third.
But that means that the innocent second stmt (p <- z) gets caught
up in the recursion.  And that in turn means that the binding for
'z' has to be included... and so on.

Start at the tail { r <- x }
Now add the next one { z <- y ; r <- x }
Now add one more     { q <- x ; z <- y ; r <- x }
Now one more... but this time we have to group a bunch into rec
     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
Now one more, which we can add on without a rec
     { p <- z ;
       rec { y <- ...x... ; q <- x ; z <- y } ;
       r <- x }
Finally we add the last one; since it mentions y we have to
glom it together with the first two groups
     { rec { x <- ...y...; p <- z ; y <- ...x... ;
             q <- x ; z <- y } ;
       r <- x }
-}

glomSegments :: HsStmtContext Name
             -> [Segment (LStmt GhcRn body)]
             -> [Segment [LStmt GhcRn body]]
                                  -- Each segment has a non-empty list of Stmts
-- See Note [Glomming segments]

glomSegments :: HsStmtContext Name
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext Name
_ [] = []
glomSegments HsStmtContext Name
ctxt ((FreeVars
defs,FreeVars
uses,FreeVars
fwds,LStmt GhcRn body
stmt) : [Segment (LStmt GhcRn body)]
segs)
        -- Actually stmts will always be a singleton
  = (FreeVars
seg_defs, FreeVars
seg_uses, FreeVars
seg_fwds, [LStmt GhcRn body]
seg_stmts)  Segment [LStmt GhcRn body]
-> [Segment [LStmt GhcRn body]] -> [Segment [LStmt GhcRn body]]
forall a. a -> [a] -> [a]
: [Segment [LStmt GhcRn body]]
others
  where
    segs' :: [Segment [LStmt GhcRn body]]
segs'            = HsStmtContext Name
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
forall body.
HsStmtContext Name
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext Name
ctxt [Segment (LStmt GhcRn body)]
segs
    ([Segment [LStmt GhcRn body]]
extras, [Segment [LStmt GhcRn body]]
others) = FreeVars
-> [Segment [LStmt GhcRn body]]
-> ([Segment [LStmt GhcRn body]], [Segment [LStmt GhcRn body]])
forall a. FreeVars -> [Segment a] -> ([Segment a], [Segment a])
grab FreeVars
uses [Segment [LStmt GhcRn body]]
segs'
    ([FreeVars]
ds, [FreeVars]
us, [FreeVars]
fs, [[LStmt GhcRn body]]
ss) = [Segment [LStmt GhcRn body]]
-> ([FreeVars], [FreeVars], [FreeVars], [[LStmt GhcRn body]])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [Segment [LStmt GhcRn body]]
extras

    seg_defs :: FreeVars
seg_defs  = [FreeVars] -> FreeVars
plusFVs [FreeVars]
ds FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
defs
    seg_uses :: FreeVars
seg_uses  = [FreeVars] -> FreeVars
plusFVs [FreeVars]
us FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
uses
    seg_fwds :: FreeVars
seg_fwds  = [FreeVars] -> FreeVars
plusFVs [FreeVars]
fs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fwds
    seg_stmts :: [LStmt GhcRn body]
seg_stmts = LStmt GhcRn body
stmt LStmt GhcRn body -> [LStmt GhcRn body] -> [LStmt GhcRn body]
forall a. a -> [a] -> [a]
: [[LStmt GhcRn body]] -> [LStmt GhcRn body]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LStmt GhcRn body]]
ss

    grab :: NameSet             -- The client
         -> [Segment a]
         -> ([Segment a],       -- Needed by the 'client'
             [Segment a])       -- Not needed by the client
        -- The result is simply a split of the input
    grab :: FreeVars -> [Segment a] -> ([Segment a], [Segment a])
grab FreeVars
uses [Segment a]
dus
        = ([Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
yeses, [Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
noes)
        where
          ([Segment a]
noes, [Segment a]
yeses)           = (Segment a -> Bool) -> [Segment a] -> ([Segment a], [Segment a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Segment a -> Bool
not_needed ([Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
dus)
          not_needed :: Segment a -> Bool
not_needed (FreeVars
defs,FreeVars
_,FreeVars
_,a
_) = Bool -> Bool
not (FreeVars -> FreeVars -> Bool
intersectsNameSet FreeVars
defs FreeVars
uses)

----------------------------------------------------
segsToStmts :: Stmt GhcRn body
                                  -- A RecStmt with the SyntaxOps filled in
            -> [Segment [LStmt GhcRn body]]
                                  -- Each Segment has a non-empty list of Stmts
            -> FreeVars           -- Free vars used 'later'
            -> ([LStmt GhcRn body], FreeVars)

segsToStmts :: Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segsToStmts Stmt GhcRn body
_ [] FreeVars
fvs_later = ([], FreeVars
fvs_later)
segsToStmts Stmt GhcRn body
empty_rec_stmt ((FreeVars
defs, FreeVars
uses, FreeVars
fwds, [LStmt GhcRn body]
ss) : [Segment [LStmt GhcRn body]]
segs) FreeVars
fvs_later
  = ASSERT( not (null ss) )
    (LStmt GhcRn body
new_stmt LStmt GhcRn body -> [LStmt GhcRn body] -> [LStmt GhcRn body]
forall a. a -> [a] -> [a]
: [LStmt GhcRn body]
later_stmts, FreeVars
later_uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
uses)
  where
    ([LStmt GhcRn body]
later_stmts, FreeVars
later_uses) = Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
forall body.
Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segsToStmts Stmt GhcRn body
empty_rec_stmt [Segment [LStmt GhcRn body]]
segs FreeVars
fvs_later
    new_stmt :: LStmt GhcRn body
new_stmt | Bool
non_rec   = [LStmt GhcRn body] -> LStmt GhcRn body
forall a. [a] -> a
head [LStmt GhcRn body]
ss
             | Bool
otherwise = SrcSpan -> SrcSpanLess (LStmt GhcRn body) -> LStmt GhcRn body
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL (LStmt GhcRn body -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc ([LStmt GhcRn body] -> LStmt GhcRn body
forall a. [a] -> a
head [LStmt GhcRn body]
ss)) SrcSpanLess (LStmt GhcRn body)
Stmt GhcRn body
rec_stmt
    rec_stmt :: Stmt GhcRn body
rec_stmt = Stmt GhcRn body
empty_rec_stmt { recS_stmts :: [LStmt GhcRn body]
recS_stmts     = [LStmt GhcRn body]
ss
                              , recS_later_ids :: [IdP GhcRn]
recS_later_ids = FreeVars -> [Name]
nameSetElemsStable FreeVars
used_later
                              , recS_rec_ids :: [IdP GhcRn]
recS_rec_ids   = FreeVars -> [Name]
nameSetElemsStable FreeVars
fwds }
          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
    non_rec :: Bool
non_rec    = [LStmt GhcRn body] -> Bool
forall a. [a] -> Bool
isSingleton [LStmt GhcRn body]
ss Bool -> Bool -> Bool
&& FreeVars -> Bool
isEmptyNameSet FreeVars
fwds
    used_later :: FreeVars
used_later = FreeVars
defs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
later_uses
                                -- The ones needed after the RecStmt

{-
************************************************************************
*                                                                      *
ApplicativeDo
*                                                                      *
************************************************************************

Note [ApplicativeDo]

= Example =

For a sequence of statements

 do
     x <- A
     y <- B x
     z <- C
     return (f x y z)

We want to transform this to

  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C

It would be easy to notice that "y <- B x" and "z <- C" are
independent and do something like this:

 do
     x <- A
     (y,z) <- (,) <$> B x <*> C
     return (f x y z)

But this isn't enough! A and C were also independent, and this
transformation loses the ability to do A and C in parallel.

The algorithm works by first splitting the sequence of statements into
independent "segments", and a separate "tail" (the final statement). In
our example above, the segements would be

     [ x <- A
     , y <- B x ]

     [ z <- C ]

and the tail is:

     return (f x y z)

Then we take these segments and make an Applicative expression from them:

     (\(x,y) z -> return (f x y z))
       <$> do { x <- A; y <- B x; return (x,y) }
       <*> C

Finally, we recursively apply the transformation to each segment, to
discover any nested parallelism.

= Syntax & spec =

  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...

  stmt ::= pat <- expr
         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
         | ...                    -- other kinds of statement (e.g. let)

  arg ::= pat <- expr
        | {stmt_1; ..; stmt_n} {var_1..var_n}

(note that in the actual implementation,the expr in a do statement is
represented by a LastStmt as the final stmt, this is just a
representational issue and may change later.)

== Transformation to introduce applicative stmts ==

ado {} tail = tail
ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
ado {one} tail = one : tail
ado stmts tail
  | n == 1 = ado before (ado after tail)
    where (before,after) = split(stmts_1)
  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
  where
    {stmts_1 .. stmts_n} = segments(stmts)

segments(stmts) =
  -- divide stmts into segments with no interdependencies

mkArg({pat <- expr}) = (pat <- expr)
mkArg({stmt_1; ...; stmt_n}) =
  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}

split({stmt_1; ..; stmt_n) =
  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
  -- 1 <= i <= n
  -- i is a good place to insert a bind

== Desugaring for do ==

dsDo {} expr = expr

dsDo {pat <- rhs; stmts} expr =
   rhs >>= \pat -> dsDo stmts expr

dsDo {(arg_1 | ... | arg_n)} (return expr) =
  (\argpat (arg_1) .. argpat(arg_n) -> expr)
     <$> argexpr(arg_1)
     <*> ...
     <*> argexpr(arg_n)

dsDo {(arg_1 | ... | arg_n); stmts} expr =
  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
     <$> argexpr(arg_1)
     <*> ...
     <*> argexpr(arg_n)

= Relevant modules in the rest of the compiler =

ApplicativeDo touches a few phases in the compiler:

* Renamer: The journey begins here in the renamer, where do-blocks are
  scheduled as outlined above and transformed into applicative
  combinators.  However, the code is still represented as a do-block
  with special forms of applicative statements. This allows us to
  recover the original do-block when e.g. printing type errors, where
  we don't want to show any of the applicative combinators since they
  don't exist in the source code.
  See ApplicativeStmt and ApplicativeArg in HsExpr.

* Typechecker: ApplicativeDo passes through the typechecker much like any
  other form of expression. The only crux is that the typechecker has to
  be aware of the special ApplicativeDo statements in the do-notation, and
  typecheck them appropriately.
  Relevant module: TcMatches

* Desugarer: Any do-block which contains applicative statements is desugared
  as outlined above, to use the Applicative combinators.
  Relevant module: DsExpr

-}

-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
-- 'pureName' due to @RebindableSyntax@.
data MonadNames = MonadNames { MonadNames -> Name
return_name, MonadNames -> Name
pure_name :: Name }

instance Outputable MonadNames where
  ppr :: MonadNames -> MsgDoc
ppr (MonadNames {return_name :: MonadNames -> Name
return_name=Name
return_name,pure_name :: MonadNames -> Name
pure_name=Name
pure_name}) =
    [MsgDoc] -> MsgDoc
hcat
    [String -> MsgDoc
text String
"MonadNames { return_name = "
    ,Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
return_name
    ,String -> MsgDoc
text String
", pure_name = "
    ,Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
pure_name
    ,String -> MsgDoc
text String
"}"
    ]

-- | rearrange a list of statements using ApplicativeDoStmt.  See
-- Note [ApplicativeDo].
rearrangeForApplicativeDo
  :: HsStmtContext Name
  -> [(ExprLStmt GhcRn, FreeVars)]
  -> RnM ([ExprLStmt GhcRn], FreeVars)

rearrangeForApplicativeDo :: HsStmtContext Name
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
rearrangeForApplicativeDo HsStmtContext Name
_ [] = ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsStmtContext Name
_ [(LStmt GhcRn (LHsExpr GhcRn)
one,FreeVars
_)] = ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LStmt GhcRn (LHsExpr GhcRn)
one], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsStmtContext Name
ctxt [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts0 = do
  Bool
optimal_ado <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_OptimalApplicativeDo
  let stmt_tree :: ExprStmtTree
stmt_tree | Bool
optimal_ado = [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
                | Bool
otherwise = [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
  String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rearrangeForADo" (ExprStmtTree -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ExprStmtTree
stmt_tree)
  Name
return_name <- Name -> RnM Name
lookupSyntaxName' Name
returnMName
  Name
pure_name   <- Name -> RnM Name
lookupSyntaxName' Name
pureAName
  let monad_names :: MonadNames
monad_names = MonadNames :: Name -> Name -> MonadNames
MonadNames { return_name :: Name
return_name = Name
return_name
                               , pure_name :: Name
pure_name   = Name
pure_name }
  MonadNames
-> HsStmtContext Name
-> ExprStmtTree
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> FreeVars
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt ExprStmtTree
stmt_tree [LStmt GhcRn (LHsExpr GhcRn)
last] FreeVars
last_fvs
  where
    ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts,(LStmt GhcRn (LHsExpr GhcRn)
last,FreeVars
last_fvs)) = [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    (LStmt GhcRn (LHsExpr GhcRn), FreeVars))
forall a. [a] -> ([a], a)
findLast [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts0
    findLast :: [a] -> ([a], a)
findLast [] = String -> ([a], a)
forall a. HasCallStack => String -> a
error String
"findLast"
    findLast [a
last] = ([],a
last)
    findLast (a
x:[a]
xs) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest,a
last) where ([a]
rest,a
last) = [a] -> ([a], a)
findLast [a]
xs

-- | A tree of statements using a mixture of applicative and bind constructs.
data StmtTree a
  = StmtTreeOne a
  | StmtTreeBind (StmtTree a) (StmtTree a)
  | StmtTreeApplicative [StmtTree a]

instance Outputable a => Outputable (StmtTree a) where
  ppr :: StmtTree a -> MsgDoc
ppr (StmtTreeOne a
x)          = MsgDoc -> MsgDoc
parens (String -> MsgDoc
text String
"StmtTreeOne" MsgDoc -> MsgDoc -> MsgDoc
<+> a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
x)
  ppr (StmtTreeBind StmtTree a
x StmtTree a
y)       = MsgDoc -> MsgDoc
parens (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"StmtTreeBind")
                                            Int
2 ([MsgDoc] -> MsgDoc
sep [StmtTree a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr StmtTree a
x, StmtTree a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr StmtTree a
y]))
  ppr (StmtTreeApplicative [StmtTree a]
xs) = MsgDoc -> MsgDoc
parens (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"StmtTreeApplicative")
                                            Int
2 ([MsgDoc] -> MsgDoc
vcat ((StmtTree a -> MsgDoc) -> [StmtTree a] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map StmtTree a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [StmtTree a]
xs)))

flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree StmtTree a
t = StmtTree a -> [a] -> [a]
forall a. StmtTree a -> [a] -> [a]
go StmtTree a
t []
 where
  go :: StmtTree a -> [a] -> [a]
go (StmtTreeOne a
a) [a]
as = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
  go (StmtTreeBind StmtTree a
l StmtTree a
r) [a]
as = StmtTree a -> [a] -> [a]
go StmtTree a
l (StmtTree a -> [a] -> [a]
go StmtTree a
r [a]
as)
  go (StmtTreeApplicative [StmtTree a]
ts) [a]
as = (StmtTree a -> [a] -> [a]) -> [a] -> [StmtTree a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StmtTree a -> [a] -> [a]
go [a]
as [StmtTree a]
ts

type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
type Cost = Int

-- | Turn a sequence of statements into an ExprStmtTree using a
-- heuristic algorithm.  /O(n^2)/
mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one] = (LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one
mkStmtTreeHeuristic [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts =
  case [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segments [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts of
    [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
one] -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
split [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
one
    [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segs -> [ExprStmtTree] -> ExprStmtTree
forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative (([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree)
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]] -> [ExprStmtTree]
forall a b. (a -> b) -> [a] -> [b]
map [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
split [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segs)
 where
  split :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
split [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one] = (LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one
  split [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts =
    ExprStmtTree -> ExprStmtTree -> ExprStmtTree
forall a. StmtTree a -> StmtTree a -> StmtTree a
StmtTreeBind ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
before) ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
after)
    where ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
before, [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
after) = [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
splitSegment [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts

-- | Turn a sequence of statements into an ExprStmtTree optimally,
-- using dynamic programming.  /O(n^3)/
mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts =
  ASSERT(not (null stmts)) -- the empty case is handled by the caller;
                           -- we don't support empty StmtTrees.
  (ExprStmtTree, Int) -> ExprStmtTree
forall a b. (a, b) -> a
fst (Array (Int, Int) (ExprStmtTree, Int)
arr Array (Int, Int) (ExprStmtTree, Int)
-> (Int, Int) -> (ExprStmtTree, Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
0,Int
n))
  where
    n :: Int
n = [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    stmt_arr :: Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr = (Int, Int)
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
n) [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts

    -- lazy cache of optimal trees for subsequences of the input
    arr :: Array (Int,Int) (ExprStmtTree, Cost)
    arr :: Array (Int, Int) (ExprStmtTree, Int)
arr = ((Int, Int), (Int, Int))
-> [((Int, Int), (ExprStmtTree, Int))]
-> Array (Int, Int) (ExprStmtTree, Int)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int
0,Int
0),(Int
n,Int
n))
             [ ((Int
lo,Int
hi), Int -> Int -> (ExprStmtTree, Int)
tree Int
lo Int
hi)
             | Int
lo <- [Int
0..Int
n]
             , Int
hi <- [Int
lo..Int
n] ]

    -- compute the optimal tree for the sequence [lo..hi]
    tree :: Int -> Int -> (ExprStmtTree, Int)
tree Int
lo Int
hi
      | Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = ((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1)
      | Bool
otherwise =
         case [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segments [ Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- [Int
lo..Int
hi] ] of
           [] -> String -> (ExprStmtTree, Int)
forall a. String -> a
panic String
"mkStmtTree"
           [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
_one] -> Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
           [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segs -> ([ExprStmtTree] -> ExprStmtTree
forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative [ExprStmtTree]
trees, [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
costs)
             where
               bounds :: [(Int, Int)]
bounds = ((Int, Int)
 -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> (Int, Int))
-> (Int, Int)
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [(Int, Int)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Int
_,Int
hi) [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
a -> (Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
a)) (Int
0,Int
loInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segs
               ([ExprStmtTree]
trees,[Int]
costs) = [(ExprStmtTree, Int)] -> ([ExprStmtTree], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip (((Int, Int) -> (ExprStmtTree, Int))
-> [(Int, Int)] -> [(ExprStmtTree, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> (ExprStmtTree, Int))
-> (Int, Int) -> (ExprStmtTree, Int)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> (ExprStmtTree, Int)
split) ([(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
tail [(Int, Int)]
bounds))

    -- find the best place to split the segment [lo..hi]
    split :: Int -> Int -> (ExprStmtTree, Cost)
    split :: Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
      | Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = ((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1)
      | Bool
otherwise = (ExprStmtTree -> ExprStmtTree -> ExprStmtTree
forall a. StmtTree a -> StmtTree a -> StmtTree a
StmtTreeBind ExprStmtTree
before ExprStmtTree
after, Int
c1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
c2)
        where
         -- As per the paper, for a sequence s1...sn, we want to find
         -- the split with the minimum cost, where the cost is the
         -- sum of the cost of the left and right subsequences.
         --
         -- As an optimisation (also in the paper) if the cost of
         -- s1..s(n-1) is different from the cost of s2..sn, we know
         -- that the optimal solution is the lower of the two.  Only
         -- in the case that these two have the same cost do we need
         -- to do the exhaustive search.
         --
         ((ExprStmtTree
before,Int
c1),(ExprStmtTree
after,Int
c2))
           | Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
           = (((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1),
              ((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
           | Int
left_cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
right_cost
           = ((ExprStmtTree
left,Int
left_cost), ((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
           | Int
left_cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
right_cost
           = (((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> ExprStmtTree
forall a. a -> StmtTree a
StmtTreeOne (Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
stmt_arr Array Int (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> Int -> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1), (ExprStmtTree
right,Int
right_cost))
           | Bool
otherwise = (((ExprStmtTree, Int), (ExprStmtTree, Int))
 -> ((ExprStmtTree, Int), (ExprStmtTree, Int)) -> Ordering)
-> [((ExprStmtTree, Int), (ExprStmtTree, Int))]
-> ((ExprStmtTree, Int), (ExprStmtTree, Int))
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((((ExprStmtTree, Int), (ExprStmtTree, Int)) -> Int)
-> ((ExprStmtTree, Int), (ExprStmtTree, Int))
-> ((ExprStmtTree, Int), (ExprStmtTree, Int))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((ExprStmtTree, Int), (ExprStmtTree, Int)) -> Int
forall a a a. Num a => ((a, a), (a, a)) -> a
cost) [((ExprStmtTree, Int), (ExprStmtTree, Int))]
alternatives
           where
             (ExprStmtTree
left, Int
left_cost) = Array (Int, Int) (ExprStmtTree, Int)
arr Array (Int, Int) (ExprStmtTree, Int)
-> (Int, Int) -> (ExprStmtTree, Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
             (ExprStmtTree
right, Int
right_cost) = Array (Int, Int) (ExprStmtTree, Int)
arr Array (Int, Int) (ExprStmtTree, Int)
-> (Int, Int) -> (ExprStmtTree, Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
loInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
hi)
             cost :: ((a, a), (a, a)) -> a
cost ((a
_,a
c1),(a
_,a
c2)) = a
c1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
c2
             alternatives :: [((ExprStmtTree, Int), (ExprStmtTree, Int))]
alternatives = [ (Array (Int, Int) (ExprStmtTree, Int)
arr Array (Int, Int) (ExprStmtTree, Int)
-> (Int, Int) -> (ExprStmtTree, Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
k), Array (Int, Int) (ExprStmtTree, Int)
arr Array (Int, Int) (ExprStmtTree, Int)
-> (Int, Int) -> (ExprStmtTree, Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
hi))
                            | Int
k <- [Int
lo .. Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]


-- | Turn the ExprStmtTree back into a sequence of statements, using
-- ApplicativeStmt where necessary.
stmtTreeToStmts
  :: MonadNames
  -> HsStmtContext Name
  -> ExprStmtTree
  -> [ExprLStmt GhcRn]             -- ^ the "tail"
  -> FreeVars                     -- ^ free variables of the tail
  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
         , FreeVars )             -- , things we needed

-- If we have a single bind, and we can do it without a join, transform
-- to an ApplicativeStmt.  This corresponds to the rule
--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
-- In the spec, but we do it here rather than in the desugarer,
-- because we need the typechecker to typecheck the <$> form rather than
-- the bind form, which would give rise to a Monad constraint.
stmtTreeToStmts :: MonadNames
-> HsStmtContext Name
-> ExprStmtTree
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> FreeVars
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt (StmtTreeOne (L SrcSpan
_ (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
fail_op), FreeVars
_))
                [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
_tail_fvs
  | Bool -> Bool
not (LPat GhcRn -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat GhcRn
pat), (Bool
False,[LStmt GhcRn (LHsExpr GhcRn)]
tail') <- MonadNames
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> (Bool, [LStmt GhcRn (LHsExpr GhcRn)])
needJoin MonadNames
monad_names [LStmt GhcRn (LHsExpr GhcRn)]
tail
  -- See Note [ApplicativeDo and strict patterns]
  = HsStmtContext Name
-> [ApplicativeArg GhcRn]
-> Bool
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
mkApplicativeStmt HsStmtContext Name
ctxt [ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne
                            { xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XApplicativeArgOne GhcRn
NoExtField
noExtField
                            , app_arg_pattern :: LPat GhcRn
app_arg_pattern  = LPat GhcRn
pat
                            , arg_expr :: LHsExpr GhcRn
arg_expr         = LHsExpr GhcRn
rhs
                            , is_body_stmt :: Bool
is_body_stmt     = Bool
False
                            , fail_operator :: SyntaxExpr GhcRn
fail_operator    = SyntaxExpr GhcRn
fail_op}]
                      Bool
False [LStmt GhcRn (LHsExpr GhcRn)]
tail'
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt (StmtTreeOne (L SrcSpan
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_),FreeVars
_))
                [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
_tail_fvs
  | (Bool
False,[LStmt GhcRn (LHsExpr GhcRn)]
tail') <- MonadNames
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> (Bool, [LStmt GhcRn (LHsExpr GhcRn)])
needJoin MonadNames
monad_names [LStmt GhcRn (LHsExpr GhcRn)]
tail
  = HsStmtContext Name
-> [ApplicativeArg GhcRn]
-> Bool
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
mkApplicativeStmt HsStmtContext Name
ctxt
      [ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne
       { xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XApplicativeArgOne GhcRn
NoExtField
noExtField
       , app_arg_pattern :: LPat GhcRn
app_arg_pattern  = LPat GhcRn
nlWildPatName
       , arg_expr :: LHsExpr GhcRn
arg_expr         = LHsExpr GhcRn
rhs
       , is_body_stmt :: Bool
is_body_stmt     = Bool
True
       , fail_operator :: SyntaxExpr GhcRn
fail_operator    = SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr}] Bool
False [LStmt GhcRn (LHsExpr GhcRn)]
tail'

stmtTreeToStmts MonadNames
_monad_names HsStmtContext Name
_ctxt (StmtTreeOne (LStmt GhcRn (LHsExpr GhcRn)
s,FreeVars
_)) [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
_tail_fvs =
  ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LStmt GhcRn (LHsExpr GhcRn)
s LStmt GhcRn (LHsExpr GhcRn)
-> [LStmt GhcRn (LHsExpr GhcRn)] -> [LStmt GhcRn (LHsExpr GhcRn)]
forall a. a -> [a] -> [a]
: [LStmt GhcRn (LHsExpr GhcRn)]
tail, FreeVars
emptyNameSet)

stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt (StmtTreeBind ExprStmtTree
before ExprStmtTree
after) [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
tail_fvs = do
  ([LStmt GhcRn (LHsExpr GhcRn)]
stmts1, FreeVars
fvs1) <- MonadNames
-> HsStmtContext Name
-> ExprStmtTree
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> FreeVars
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt ExprStmtTree
after [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
tail_fvs
  let tail1_fvs :: FreeVars
tail1_fvs = [FreeVars] -> FreeVars
unionNameSets (FreeVars
tail_fvs FreeVars -> [FreeVars] -> [FreeVars]
forall a. a -> [a] -> [a]
: ((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> FreeVars)
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map (LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> FreeVars
forall a b. (a, b) -> b
snd (ExprStmtTree -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. StmtTree a -> [a]
flattenStmtTree ExprStmtTree
after))
  ([LStmt GhcRn (LHsExpr GhcRn)]
stmts2, FreeVars
fvs2) <- MonadNames
-> HsStmtContext Name
-> ExprStmtTree
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> FreeVars
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt ExprStmtTree
before [LStmt GhcRn (LHsExpr GhcRn)]
stmts1 FreeVars
tail1_fvs
  ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LStmt GhcRn (LHsExpr GhcRn)]
stmts2, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)

stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt (StmtTreeApplicative [ExprStmtTree]
trees) [LStmt GhcRn (LHsExpr GhcRn)]
tail FreeVars
tail_fvs = do
   [(ApplicativeArg GhcRn, FreeVars)]
pairs <- (ExprStmtTree
 -> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars))
-> [ExprStmtTree]
-> IOEnv (Env TcGblEnv TcLclEnv) [(ApplicativeArg GhcRn, FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsStmtContext Name
-> FreeVars
-> ExprStmtTree
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
stmtTreeArg HsStmtContext Name
ctxt FreeVars
tail_fvs) [ExprStmtTree]
trees
   let ([ApplicativeArg GhcRn]
stmts', [FreeVars]
fvss) = [(ApplicativeArg GhcRn, FreeVars)]
-> ([ApplicativeArg GhcRn], [FreeVars])
forall a b. [(a, b)] -> ([a], [b])
unzip [(ApplicativeArg GhcRn, FreeVars)]
pairs
   let (Bool
need_join, [LStmt GhcRn (LHsExpr GhcRn)]
tail') =
     -- See Note [ApplicativeDo and refutable patterns]
         if (ApplicativeArg GhcRn -> Bool) -> [ApplicativeArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ApplicativeArg GhcRn -> Bool
hasRefutablePattern [ApplicativeArg GhcRn]
stmts'
         then (Bool
True, [LStmt GhcRn (LHsExpr GhcRn)]
tail)
         else MonadNames
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> (Bool, [LStmt GhcRn (LHsExpr GhcRn)])
needJoin MonadNames
monad_names [LStmt GhcRn (LHsExpr GhcRn)]
tail

   ([LStmt GhcRn (LHsExpr GhcRn)]
stmts, FreeVars
fvs) <- HsStmtContext Name
-> [ApplicativeArg GhcRn]
-> Bool
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
mkApplicativeStmt HsStmtContext Name
ctxt [ApplicativeArg GhcRn]
stmts' Bool
need_join [LStmt GhcRn (LHsExpr GhcRn)]
tail'
   ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LStmt GhcRn (LHsExpr GhcRn)]
stmts, [FreeVars] -> FreeVars
unionNameSets (FreeVars
fvsFreeVars -> [FreeVars] -> [FreeVars]
forall a. a -> [a] -> [a]
:[FreeVars]
fvss))
 where
   stmtTreeArg :: HsStmtContext Name
-> FreeVars
-> ExprStmtTree
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
stmtTreeArg HsStmtContext Name
_ctxt FreeVars
_tail_fvs (StmtTreeOne (L SrcSpan
_ (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
exp SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
fail_op), FreeVars
_))
     = (ApplicativeArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne
               { xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XApplicativeArgOne GhcRn
NoExtField
noExtField
               , app_arg_pattern :: LPat GhcRn
app_arg_pattern  = LPat GhcRn
pat
               , arg_expr :: LHsExpr GhcRn
arg_expr         = LHsExpr GhcRn
exp
               , is_body_stmt :: Bool
is_body_stmt     = Bool
False
               , fail_operator :: SyntaxExpr GhcRn
fail_operator    = SyntaxExpr GhcRn
fail_op
               }, FreeVars
emptyFVs)
   stmtTreeArg HsStmtContext Name
_ctxt FreeVars
_tail_fvs (StmtTreeOne (L SrcSpan
_ (BodyStmt XBodyStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
exp SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_), FreeVars
_)) =
     (ApplicativeArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne :: forall idL.
XApplicativeArgOne idL
-> LPat idL
-> LHsExpr idL
-> Bool
-> SyntaxExpr idL
-> ApplicativeArg idL
ApplicativeArgOne
             { xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XApplicativeArgOne GhcRn
NoExtField
noExtField
             , app_arg_pattern :: LPat GhcRn
app_arg_pattern  = LPat GhcRn
nlWildPatName
             , arg_expr :: LHsExpr GhcRn
arg_expr         = LHsExpr GhcRn
exp
             , is_body_stmt :: Bool
is_body_stmt     = Bool
True
             , fail_operator :: SyntaxExpr GhcRn
fail_operator    = SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
             }, FreeVars
emptyFVs)
   stmtTreeArg HsStmtContext Name
ctxt FreeVars
tail_fvs ExprStmtTree
tree = do
     let stmts :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts = ExprStmtTree -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. StmtTree a -> [a]
flattenStmtTree ExprStmtTree
tree
         pvarset :: FreeVars
pvarset = [Name] -> FreeVars
mkNameSet (((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> [Name])
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> [Name]
forall (idL :: Pass) (idR :: Pass) body.
StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders(StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> [Name])
-> ((LStmt GhcRn (LHsExpr GhcRn), FreeVars)
    -> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LStmt GhcRn (LHsExpr GhcRn) -> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc(LStmt GhcRn (LHsExpr GhcRn) -> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> ((LStmt GhcRn (LHsExpr GhcRn), FreeVars)
    -> LStmt GhcRn (LHsExpr GhcRn))
-> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> LStmt GhcRn (LHsExpr GhcRn)
forall a b. (a, b) -> a
fst) [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts)
                     FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
tail_fvs
         pvars :: [Name]
pvars = FreeVars -> [Name]
nameSetElemsStable FreeVars
pvarset
           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
         pat :: LPat GhcRn
pat = [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup [Name]
[IdP GhcRn]
pvars
         tup :: LHsExpr GhcRn
tup = [IdP GhcRn] -> LHsExpr GhcRn
forall (id :: Pass). [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsVarTup [Name]
[IdP GhcRn]
pvars
     ([LStmt GhcRn (LHsExpr GhcRn)]
stmts',FreeVars
fvs2) <- MonadNames
-> HsStmtContext Name
-> ExprStmtTree
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> FreeVars
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext Name
ctxt ExprStmtTree
tree [] FreeVars
pvarset
     (HsExpr GhcRn
mb_ret, FreeVars
fvs1) <-
        if | L SrcSpan
_ ApplicativeStmt{} <- [LStmt GhcRn (LHsExpr GhcRn)] -> LStmt GhcRn (LHsExpr GhcRn)
forall a. [a] -> a
last [LStmt GhcRn (LHsExpr GhcRn)]
stmts' ->
             (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
tup, FreeVars
emptyNameSet)
           | Bool
otherwise -> do
             Name
ret <- Name -> RnM Name
lookupSyntaxName' Name
returnMName
             let expr :: HsExpr GhcRn
expr = XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (Located Name)
ret))) LHsExpr GhcRn
tup
             (HsExpr GhcRn, FreeVars) -> RnM (HsExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
expr, FreeVars
emptyFVs)
     (ApplicativeArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ApplicativeArgMany :: forall idL.
XApplicativeArgMany idL
-> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> ApplicativeArg idL
ApplicativeArgMany
              { xarg_app_arg_many :: XApplicativeArgMany GhcRn
xarg_app_arg_many = XApplicativeArgMany GhcRn
NoExtField
noExtField
              , app_stmts :: [LStmt GhcRn (LHsExpr GhcRn)]
app_stmts         = [LStmt GhcRn (LHsExpr GhcRn)]
stmts'
              , final_expr :: HsExpr GhcRn
final_expr        = HsExpr GhcRn
mb_ret
              , bv_pattern :: LPat GhcRn
bv_pattern        = LPat GhcRn
pat
              }
            , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)


-- | Divide a sequence of statements into segments, where no segment
-- depends on any variables defined by a statement in another segment.
segments
  :: [(ExprLStmt GhcRn, FreeVars)]
  -> [[(ExprLStmt GhcRn, FreeVars)]]
segments :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
segments [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts = (([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)
 -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
-> [([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a b. (a -> b) -> [a] -> [b]
map ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a b. (a, b) -> a
fst ([([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)]
 -> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]])
-> [([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a b. (a -> b) -> a -> b
$ [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)]
forall a b b. [[(LStmt a b, b)]] -> [([(LStmt a b, b)], Bool)]
merge ([[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
 -> [([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)])
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)], Bool)]
forall a b. (a -> b) -> a -> b
$ [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a. [a] -> [a]
reverse ([[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
 -> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]])
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a b. (a -> b) -> a -> b
$ ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
 -> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a b. (a -> b) -> [a] -> [b]
map [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. [a] -> [a]
reverse ([[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
 -> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]])
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a b. (a -> b) -> a -> b
$ [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
walk ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. [a] -> [a]
reverse [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts)
  where
    allvars :: FreeVars
allvars = [Name] -> FreeVars
mkNameSet (((LStmt GhcRn (LHsExpr GhcRn), FreeVars) -> [Name])
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> [Name]
forall (idL :: Pass) (idR :: Pass) body.
StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders(StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> [Name])
-> ((LStmt GhcRn (LHsExpr GhcRn), FreeVars)
    -> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LStmt GhcRn (LHsExpr GhcRn) -> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc(LStmt GhcRn (LHsExpr GhcRn) -> StmtLR GhcRn GhcRn (LHsExpr GhcRn))
-> ((LStmt GhcRn (LHsExpr GhcRn), FreeVars)
    -> LStmt GhcRn (LHsExpr GhcRn))
-> (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> LStmt GhcRn (LHsExpr GhcRn)
forall a b. (a, b) -> a
fst) [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts)

    -- We would rather not have a segment that just has LetStmts in
    -- it, so combine those with an adjacent segment where possible.
    merge :: [[(LStmt a b, b)]] -> [([(LStmt a b, b)], Bool)]
merge [] = []
    merge ([(LStmt a b, b)]
seg : [[(LStmt a b, b)]]
segs)
       = case [([(LStmt a b, b)], Bool)]
rest of
          [] -> [([(LStmt a b, b)]
seg,Bool
all_lets)]
          (([(LStmt a b, b)]
s,Bool
s_lets):[([(LStmt a b, b)], Bool)]
ss) | Bool
all_lets Bool -> Bool -> Bool
|| Bool
s_lets
               -> ([(LStmt a b, b)]
seg [(LStmt a b, b)] -> [(LStmt a b, b)] -> [(LStmt a b, b)]
forall a. [a] -> [a] -> [a]
++ [(LStmt a b, b)]
s, Bool
all_lets Bool -> Bool -> Bool
&& Bool
s_lets) ([(LStmt a b, b)], Bool)
-> [([(LStmt a b, b)], Bool)] -> [([(LStmt a b, b)], Bool)]
forall a. a -> [a] -> [a]
: [([(LStmt a b, b)], Bool)]
ss
          [([(LStmt a b, b)], Bool)]
_otherwise -> ([(LStmt a b, b)]
seg,Bool
all_lets) ([(LStmt a b, b)], Bool)
-> [([(LStmt a b, b)], Bool)] -> [([(LStmt a b, b)], Bool)]
forall a. a -> [a] -> [a]
: [([(LStmt a b, b)], Bool)]
rest
      where
        rest :: [([(LStmt a b, b)], Bool)]
rest = [[(LStmt a b, b)]] -> [([(LStmt a b, b)], Bool)]
merge [[(LStmt a b, b)]]
segs
        all_lets :: Bool
all_lets = ((LStmt a b, b) -> Bool) -> [(LStmt a b, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (LStmt a b -> Bool
forall a b. LStmt a b -> Bool
isLetStmt (LStmt a b -> Bool)
-> ((LStmt a b, b) -> LStmt a b) -> (LStmt a b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LStmt a b, b) -> LStmt a b
forall a b. (a, b) -> a
fst) [(LStmt a b, b)]
seg

    -- walk splits the statement sequence into segments, traversing
    -- the sequence from the back to the front, and keeping track of
    -- the set of free variables of the current segment.  Whenever
    -- this set of free variables is empty, we have a complete segment.
    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
    walk :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
walk [] = []
    walk ((LStmt GhcRn (LHsExpr GhcRn)
stmt,FreeVars
fvs) : [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts) = ((LStmt GhcRn (LHsExpr GhcRn)
stmt,FreeVars
fvs) (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. a -> [a] -> [a]
: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
seg) [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
forall a. a -> [a] -> [a]
: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]]
walk [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest
      where ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
seg,[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest) = FreeVars
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
chunter FreeVars
fvs' [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
            (FreeVars
_, FreeVars
fvs') = LStmt GhcRn (LHsExpr GhcRn) -> FreeVars -> (FreeVars, FreeVars)
stmtRefs LStmt GhcRn (LHsExpr GhcRn)
stmt FreeVars
fvs

    chunter :: FreeVars
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
chunter FreeVars
_ [] = ([], [])
    chunter FreeVars
vars ((LStmt GhcRn (LHsExpr GhcRn)
stmt,FreeVars
fvs) : [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest)
       | Bool -> Bool
not (FreeVars -> Bool
isEmptyNameSet FreeVars
vars)
       Bool -> Bool -> Bool
|| LStmt GhcRn (LHsExpr GhcRn) -> Bool
isStrictPatternBind LStmt GhcRn (LHsExpr GhcRn)
stmt
           -- See Note [ApplicativeDo and strict patterns]
       = ((LStmt GhcRn (LHsExpr GhcRn)
stmt,FreeVars
fvs) (LStmt GhcRn (LHsExpr GhcRn), FreeVars)
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. a -> [a] -> [a]
: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
chunk, [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest')
       where ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
chunk,[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest') = FreeVars
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
chunter FreeVars
vars' [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest
             (FreeVars
pvars, FreeVars
evars) = LStmt GhcRn (LHsExpr GhcRn) -> FreeVars -> (FreeVars, FreeVars)
stmtRefs LStmt GhcRn (LHsExpr GhcRn)
stmt FreeVars
fvs
             vars' :: FreeVars
vars' = (FreeVars
vars FreeVars -> FreeVars -> FreeVars
`minusNameSet` FreeVars
pvars) FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
evars
    chunter FreeVars
_ [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest = ([], [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest)

    stmtRefs :: LStmt GhcRn (LHsExpr GhcRn) -> FreeVars -> (FreeVars, FreeVars)
stmtRefs LStmt GhcRn (LHsExpr GhcRn)
stmt FreeVars
fvs
      | LStmt GhcRn (LHsExpr GhcRn) -> Bool
forall a b. LStmt a b -> Bool
isLetStmt LStmt GhcRn (LHsExpr GhcRn)
stmt = (FreeVars
pvars, FreeVars
fvs' FreeVars -> FreeVars -> FreeVars
`minusNameSet` FreeVars
pvars)
      | Bool
otherwise      = (FreeVars
pvars, FreeVars
fvs')
      where fvs' :: FreeVars
fvs' = FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
allvars
            pvars :: FreeVars
pvars = [Name] -> FreeVars
mkNameSet (StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders (LStmt GhcRn (LHsExpr GhcRn)
-> SrcSpanLess (LStmt GhcRn (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LStmt GhcRn (LHsExpr GhcRn)
stmt))

    isStrictPatternBind :: ExprLStmt GhcRn -> Bool
    isStrictPatternBind :: LStmt GhcRn (LHsExpr GhcRn) -> Bool
isStrictPatternBind (L SrcSpan
_ (BindStmt XBindStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LPat GhcRn
pat LHsExpr GhcRn
_ SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_)) = LPat GhcRn -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat GhcRn
pat
    isStrictPatternBind LStmt GhcRn (LHsExpr GhcRn)
_ = Bool
False

{-
Note [ApplicativeDo and strict patterns]

A strict pattern match is really a dependency.  For example,

do
  (x,y) <- A
  z <- B
  return C

The pattern (_,_) must be matched strictly before we do B.  If we
allowed this to be transformed into

  (\(x,y) -> \z -> C) <$> A <*> B

then it could be lazier than the standard desuraging using >>=.  See #13875
for more examples.

Thus, whenever we have a strict pattern match, we treat it as a
dependency between that statement and the following one.  The
dependency prevents those two statements from being performed "in
parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
can do with the rest of the statements in the same "do" expression.
-}

isStrictPattern :: LPat (GhcPass p) -> Bool
isStrictPattern :: LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
lpat =
  case Located (Pat (GhcPass p))
-> SrcSpanLess (Located (Pat (GhcPass p)))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat (GhcPass p))
LPat (GhcPass p)
lpat of
    WildPat{}       -> Bool
False
    VarPat{}        -> Bool
False
    LazyPat{}       -> Bool
False
    AsPat _ _ p     -> LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
    ParPat _ p      -> LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
    ViewPat _ _ p   -> LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
    SigPat _ p _    -> LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
    BangPat{}       -> Bool
True
    ListPat{}       -> Bool
True
    TuplePat{}      -> Bool
True
    SumPat{}        -> Bool
True
    ConPatIn{}      -> Bool
True
    ConPatOut{}     -> Bool
True
    LitPat{}        -> Bool
True
    NPat{}          -> Bool
True
    NPlusKPat{}     -> Bool
True
    SplicePat{}     -> Bool
True
    SrcSpanLess (Located (Pat (GhcPass p)))
_otherwise -> String -> Bool
forall a. String -> a
panic String
"isStrictPattern"

{-
Note [ApplicativeDo and refutable patterns]

Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
This means that sometimes an applicative block needs to be wrapped in 'join' simply because
of a refutable pattern, in order for the types to work out.

-}

hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
hasRefutablePattern (ApplicativeArgOne { app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
app_arg_pattern = LPat GhcRn
pat
                                       , is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
is_body_stmt = Bool
False}) = Bool -> Bool
not (LPat GhcRn -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
isIrrefutableHsPat LPat GhcRn
pat)
hasRefutablePattern ApplicativeArg GhcRn
_ = Bool
False

isLetStmt :: LStmt a b -> Bool
isLetStmt :: LStmt a b -> Bool
isLetStmt (L SrcSpan
_ LetStmt{}) = Bool
True
isLetStmt LStmt a b
_ = Bool
False

-- | Find a "good" place to insert a bind in an indivisible segment.
-- This is the only place where we use heuristics.  The current
-- heuristic is to peel off the first group of independent statements
-- and put the bind after those.
splitSegment
  :: [(ExprLStmt GhcRn, FreeVars)]
  -> ( [(ExprLStmt GhcRn, FreeVars)]
     , [(ExprLStmt GhcRn, FreeVars)] )
splitSegment :: [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
    [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
splitSegment [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one,(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
two] = ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
one],[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
two])
  -- there is no choice when there are only two statements; this just saves
  -- some work in a common case.
splitSegment [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
  | Just ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
lets,[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
binds,[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest) <- [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> Maybe
     ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
      [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)],
      [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)])
forall (body :: * -> *).
[(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> Maybe
     ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)])
slurpIndependentStmts [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts
  =  if Bool -> Bool
not ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
lets)
       then ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
lets, [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
binds[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest)
       else ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
lets[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
-> [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
forall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
binds, [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
rest)
  | Bool
otherwise
  = case [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts of
      ((LStmt GhcRn (LHsExpr GhcRn), FreeVars)
x:[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
xs) -> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)
x],[(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
xs)
      [(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
_other -> ([(LStmt GhcRn (LHsExpr GhcRn), FreeVars)]
stmts,[])

slurpIndependentStmts
   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts
            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts
            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
slurpIndependentStmts :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> Maybe
     ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)])
slurpIndependentStmts [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts = [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> FreeVars
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> Maybe
     ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)],
      [(LStmt GhcRn (Located (body GhcRn)), FreeVars)])
forall (p :: Pass) idR body body l.
(IdP (GhcPass p) ~ Name,
 XBindStmt (GhcPass p) idR body ~ NoExtField,
 XLetStmt (GhcPass p) idR body ~ XLetStmt (GhcPass p) idR body) =>
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> FreeVars
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> Maybe
     ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
go [] [] FreeVars
emptyNameSet [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
stmts
 where
  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
  -- in this group, then add it to the group. We have to be careful about
  -- strict patterns though; splitSegments expects that if we return Just
  -- then we have actually done some splitting. Otherwise it will go into
  -- an infinite loop (#14163).
  go :: [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> FreeVars
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> Maybe
     ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
bndrs ((L l
loc (BindStmt XBindStmt (GhcPass p) idR body
_ LPat (GhcPass p)
pat body
body SyntaxExpr idR
bind_op SyntaxExpr idR
fail_op), FreeVars
fvs): [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest)
    | FreeVars -> Bool
isEmptyNameSet (FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs) Bool -> Bool -> Bool
&& Bool -> Bool
not (LPat (GhcPass p) -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
pat)
    = [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> FreeVars
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> Maybe
     ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets ((l
-> StmtLR (GhcPass p) idR body
-> GenLocated l (StmtLR (GhcPass p) idR body)
forall l e. l -> e -> GenLocated l e
L l
loc (XBindStmt (GhcPass p) idR body
-> LPat (GhcPass p)
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR (GhcPass p) idR body
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt XBindStmt (GhcPass p) idR body
NoExtField
noExtField LPat (GhcPass p)
pat body
body SyntaxExpr idR
bind_op SyntaxExpr idR
fail_op), FreeVars
fvs) (GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. a -> [a] -> [a]
: [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep)
         FreeVars
bndrs' [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest
    where bndrs' :: FreeVars
bndrs' = FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` [Name] -> FreeVars
mkNameSet (LPat (GhcPass p) -> [IdP (GhcPass p)]
forall (p :: Pass). LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders LPat (GhcPass p)
pat)
  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
  -- group, then move it to the beginning, so that it doesn't interfere with
  -- grouping more BindStmts.
  -- TODO: perhaps we shouldn't do this if there are any strict bindings,
  -- because we might be moving evaluation earlier.
  go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
bndrs ((L l
loc (LetStmt XLetStmt (GhcPass p) idR body
noExtField LHsLocalBindsLR (GhcPass p) idR
binds), FreeVars
fvs) : [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest)
    | FreeVars -> Bool
isEmptyNameSet (FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs)
    = [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> FreeVars
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> Maybe
     ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
go ((l
-> StmtLR (GhcPass p) idR body
-> GenLocated l (StmtLR (GhcPass p) idR body)
forall l e. l -> e -> GenLocated l e
L l
loc (XLetStmt (GhcPass p) idR body
-> LHsLocalBindsLR (GhcPass p) idR -> StmtLR (GhcPass p) idR body
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt (GhcPass p) idR body
XLetStmt (GhcPass p) idR body
noExtField LHsLocalBindsLR (GhcPass p) idR
binds), FreeVars
fvs) (GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. a -> [a] -> [a]
: [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets) [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
bndrs [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest
  go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ []  FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ = Maybe
  ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
   [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
   [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. Maybe a
Nothing
  go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
_] FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ = Maybe
  ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
   [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
   [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. Maybe a
Nothing
  go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
stmts = ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
 [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
 [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
-> Maybe
     ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
      [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. a -> Maybe a
Just ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets, [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep, [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
stmts)

-- | Build an ApplicativeStmt, and strip the "return" from the tail
-- if necessary.
--
-- For example, if we start with
--   do x <- E1; y <- E2; return (f x y)
-- then we get
--   do (E1[x] | E2[y]); f x y
--
-- the LastStmt in this case has the return removed, but we set the
-- flag on the LastStmt to indicate this, so that we can print out the
-- original statement correctly in error messages.  It is easier to do
-- it this way rather than try to ignore the return later in both the
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
  :: HsStmtContext Name
  -> [ApplicativeArg GhcRn]             -- ^ The args
  -> Bool                               -- ^ True <=> need a join
  -> [ExprLStmt GhcRn]        -- ^ The body statements
  -> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt :: HsStmtContext Name
-> [ApplicativeArg GhcRn]
-> Bool
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
mkApplicativeStmt HsStmtContext Name
ctxt [ApplicativeArg GhcRn]
args Bool
need_join [LStmt GhcRn (LHsExpr GhcRn)]
body_stmts
  = do { (SyntaxExpr GhcRn
fmap_op, FreeVars
fvs1) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
fmapName
       ; (SyntaxExpr GhcRn
ap_op, FreeVars
fvs2) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
apAName
       ; (Maybe (SyntaxExpr GhcRn)
mb_join, FreeVars
fvs3) <-
           if Bool
need_join then
             do { (SyntaxExpr GhcRn
join_op, FreeVars
fvs) <- HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext Name
ctxt Name
joinMName
                ; (Maybe (SyntaxExpr GhcRn), FreeVars)
-> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn -> Maybe (SyntaxExpr GhcRn)
forall a. a -> Maybe a
Just SyntaxExpr GhcRn
join_op, FreeVars
fvs) }
           else
             (Maybe (SyntaxExpr GhcRn), FreeVars)
-> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SyntaxExpr GhcRn)
forall a. Maybe a
Nothing, FreeVars
emptyNameSet)
       ; let applicative_stmt :: LStmt GhcRn (LHsExpr GhcRn)
applicative_stmt = SrcSpanLess (LStmt GhcRn (LHsExpr GhcRn))
-> LStmt GhcRn (LHsExpr GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LStmt GhcRn (LHsExpr GhcRn))
 -> LStmt GhcRn (LHsExpr GhcRn))
-> SrcSpanLess (LStmt GhcRn (LHsExpr GhcRn))
-> LStmt GhcRn (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XApplicativeStmt GhcRn GhcRn (LHsExpr GhcRn)
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> Maybe (SyntaxExpr GhcRn)
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt XApplicativeStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField
               ([SyntaxExpr GhcRn]
-> [ApplicativeArg GhcRn]
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
zip (SyntaxExpr GhcRn
fmap_op SyntaxExpr GhcRn -> [SyntaxExpr GhcRn] -> [SyntaxExpr GhcRn]
forall a. a -> [a] -> [a]
: SyntaxExpr GhcRn -> [SyntaxExpr GhcRn]
forall a. a -> [a]
repeat SyntaxExpr GhcRn
ap_op) [ApplicativeArg GhcRn]
args)
               Maybe (SyntaxExpr GhcRn)
mb_join
       ; ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
-> RnM ([LStmt GhcRn (LHsExpr GhcRn)], FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( LStmt GhcRn (LHsExpr GhcRn)
applicative_stmt LStmt GhcRn (LHsExpr GhcRn)
-> [LStmt GhcRn (LHsExpr GhcRn)] -> [LStmt GhcRn (LHsExpr GhcRn)]
forall a. a -> [a] -> [a]
: [LStmt GhcRn (LHsExpr GhcRn)]
body_stmts
                , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }

-- | Given the statements following an ApplicativeStmt, determine whether
-- we need a @join@ or not, and remove the @return@ if necessary.
needJoin :: MonadNames
         -> [ExprLStmt GhcRn]
         -> (Bool, [ExprLStmt GhcRn])
needJoin :: MonadNames
-> [LStmt GhcRn (LHsExpr GhcRn)]
-> (Bool, [LStmt GhcRn (LHsExpr GhcRn)])
needJoin MonadNames
_monad_names [] = (Bool
False, [])  -- we're in an ApplicativeArg
needJoin MonadNames
monad_names  [L SrcSpan
loc (LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
_ LHsExpr GhcRn
e Bool
_ SyntaxExpr GhcRn
t)]
 | Just LHsExpr GhcRn
arg <- MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
isReturnApp MonadNames
monad_names LHsExpr GhcRn
e =
       (Bool
False, [SrcSpan
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
-> LStmt GhcRn (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
-> LHsExpr GhcRn
-> Bool
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (LHsExpr GhcRn)
forall idL idR body.
XLastStmt idL idR body
-> body -> Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (LHsExpr GhcRn)
NoExtField
noExtField LHsExpr GhcRn
arg Bool
True SyntaxExpr GhcRn
t)])
needJoin MonadNames
_monad_names [LStmt GhcRn (LHsExpr GhcRn)]
stmts = (Bool
True, [LStmt GhcRn (LHsExpr GhcRn)]
stmts)

-- | @Just e@, if the expression is @return e@ or @return $ e@,
-- otherwise @Nothing@
isReturnApp :: MonadNames
            -> LHsExpr GhcRn
            -> Maybe (LHsExpr GhcRn)
isReturnApp :: MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
isReturnApp MonadNames
monad_names (L SrcSpan
_ (HsPar XPar GhcRn
_ LHsExpr GhcRn
expr)) = MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
isReturnApp MonadNames
monad_names LHsExpr GhcRn
expr
isReturnApp MonadNames
monad_names (L SrcSpan
_ HsExpr GhcRn
e) = case HsExpr GhcRn
e of
  OpApp XOpApp GhcRn
_ LHsExpr GhcRn
l LHsExpr GhcRn
op LHsExpr GhcRn
r | LHsExpr GhcRn -> Bool
is_return LHsExpr GhcRn
l, LHsExpr GhcRn -> Bool
is_dollar LHsExpr GhcRn
op -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
forall a. a -> Maybe a
Just LHsExpr GhcRn
r
  HsApp XApp GhcRn
_ LHsExpr GhcRn
f LHsExpr GhcRn
arg  | LHsExpr GhcRn -> Bool
is_return LHsExpr GhcRn
f               -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
forall a. a -> Maybe a
Just LHsExpr GhcRn
arg
  HsExpr GhcRn
_otherwise -> Maybe (LHsExpr GhcRn)
forall a. Maybe a
Nothing
 where
  is_var :: (IdP p -> Bool) -> LHsExpr p -> Bool
is_var IdP p -> Bool
f (L SrcSpan
_ (HsPar XPar p
_ LHsExpr p
e)) = (IdP p -> Bool) -> LHsExpr p -> Bool
is_var IdP p -> Bool
f LHsExpr p
e
  is_var IdP p -> Bool
f (L SrcSpan
_ (HsAppType XAppTypeE p
_ LHsExpr p
e LHsWcType (NoGhcTc p)
_)) = (IdP p -> Bool) -> LHsExpr p -> Bool
is_var IdP p -> Bool
f LHsExpr p
e
  is_var IdP p -> Bool
f (L SrcSpan
_ (HsVar XVar p
_ (L SrcSpan
_ IdP p
r))) = IdP p -> Bool
f IdP p
r
       -- TODO: I don't know how to get this right for rebindable syntax
  is_var IdP p -> Bool
_ LHsExpr p
_ = Bool
False

  is_return :: LHsExpr GhcRn -> Bool
is_return = (IdP GhcRn -> Bool) -> LHsExpr GhcRn -> Bool
forall p. (IdP p -> Bool) -> LHsExpr p -> Bool
is_var (\IdP GhcRn
n -> Name
IdP GhcRn
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
return_name MonadNames
monad_names
                         Bool -> Bool -> Bool
|| Name
IdP GhcRn
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
pure_name MonadNames
monad_names)
  is_dollar :: LHsExpr GhcRn -> Bool
is_dollar = (IdP GhcRn -> Bool) -> LHsExpr GhcRn -> Bool
forall p. (IdP p -> Bool) -> LHsExpr p -> Bool
is_var (IdP GhcRn -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey)

{-
************************************************************************
*                                                                      *
\subsubsection{Errors}
*                                                                      *
************************************************************************
-}

checkEmptyStmts :: HsStmtContext Name -> RnM ()
-- We've seen an empty sequence of Stmts... is that ok?
checkEmptyStmts :: HsStmtContext Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContext Name
ctxt
  = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HsStmtContext Name -> Bool
forall id. HsStmtContext id -> Bool
okEmpty HsStmtContext Name
ctxt) (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsStmtContext Name -> MsgDoc
emptyErr HsStmtContext Name
ctxt))

okEmpty :: HsStmtContext a -> Bool
okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = Bool
True
okEmpty HsStmtContext a
_             = Bool
False

emptyErr :: HsStmtContext Name -> SDoc
emptyErr :: HsStmtContext Name -> MsgDoc
emptyErr (ParStmtCtxt {})   = String -> MsgDoc
text String
"Empty statement group in parallel comprehension"
emptyErr (TransStmtCtxt {}) = String -> MsgDoc
text String
"Empty statement group preceding 'group' or 'then'"
emptyErr HsStmtContext Name
ctxt               = String -> MsgDoc
text String
"Empty" MsgDoc -> MsgDoc -> MsgDoc
<+> HsStmtContext Name -> MsgDoc
forall id.
(Outputable id, Outputable (NameOrRdrName id)) =>
HsStmtContext id -> MsgDoc
pprStmtContext HsStmtContext Name
ctxt

----------------------
checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
              -> LStmt GhcPs (Located (body GhcPs))
              -> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt :: HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt HsStmtContext Name
ctxt lstmt :: LStmt GhcPs (Located (body GhcPs))
lstmt@(L SrcSpan
loc StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt)
  = case HsStmtContext Name
ctxt of
      HsStmtContext Name
ListComp  -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_comp
      HsStmtContext Name
MonadComp -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_comp
      HsStmtContext Name
ArrowExpr -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_do
      HsStmtContext Name
DoExpr    -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_do
      HsStmtContext Name
MDoExpr   -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_do
      HsStmtContext Name
_         -> RnM (LStmt GhcPs (Located (body GhcPs)))
check_other
  where
    check_do :: RnM (LStmt GhcPs (Located (body GhcPs)))
check_do    -- Expect BodyStmt, and change it to LastStmt
      = case StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt of
          BodyStmt XBodyStmt GhcPs GhcPs (Located (body GhcPs))
_ Located (body GhcPs)
e SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_ -> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (Located (body GhcPs))
-> LStmt GhcPs (Located (body GhcPs))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Located (body GhcPs) -> StmtLR GhcPs GhcPs (Located (body GhcPs))
forall (bodyR :: * -> *) (idR :: Pass) (idL :: Pass).
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt Located (body GhcPs)
e))
          LastStmt {}      -> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (Located (body GhcPs))
lstmt   -- "Deriving" clauses may generate a
                                             -- LastStmt directly (unlike the parser)
          StmtLR GhcPs GhcPs (Located (body GhcPs))
_                -> do { MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang MsgDoc
last_error Int
2 (StmtLR GhcPs GhcPs (Located (body GhcPs)) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt)); LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (Located (body GhcPs))
lstmt }
    last_error :: MsgDoc
last_error = (String -> MsgDoc
text String
"The last statement in" MsgDoc -> MsgDoc -> MsgDoc
<+> HsStmtContext Name -> MsgDoc
forall id.
(Outputable id, Outputable (NameOrRdrName id)) =>
HsStmtContext id -> MsgDoc
pprAStmtContext HsStmtContext Name
ctxt
                  MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"must be an expression")

    check_comp :: RnM (LStmt GhcPs (Located (body GhcPs)))
check_comp  -- Expect LastStmt; this should be enforced by the parser!
      = case StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt of
          LastStmt {} -> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (Located (body GhcPs))
lstmt
          StmtLR GhcPs GhcPs (Located (body GhcPs))
_           -> String -> MsgDoc -> RnM (LStmt GhcPs (Located (body GhcPs)))
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"checkLastStmt" (LStmt GhcPs (Located (body GhcPs)) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LStmt GhcPs (Located (body GhcPs))
lstmt)

    check_other :: RnM (LStmt GhcPs (Located (body GhcPs)))
check_other -- Behave just as if this wasn't the last stmt
      = do { HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (body :: * -> *).
HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext Name
ctxt LStmt GhcPs (Located (body GhcPs))
lstmt; LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (Located (body GhcPs))
lstmt }

-- Checking when a particular Stmt is ok
checkStmt :: HsStmtContext Name
          -> LStmt GhcPs (Located (body GhcPs))
          -> RnM ()
checkStmt :: HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext Name
ctxt (L SrcSpan
_ StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt)
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; case DynFlags
-> HsStmtContext Name
-> StmtLR GhcPs GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext Name
ctxt StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt of
           Validity
IsValid        -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           NotValid MsgDoc
extra -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (MsgDoc
msg MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
extra) }
  where
   msg :: MsgDoc
msg = [MsgDoc] -> MsgDoc
sep [ String -> MsgDoc
text String
"Unexpected" MsgDoc -> MsgDoc -> MsgDoc
<+> StmtLR GhcPs GhcPs (Located (body GhcPs)) -> MsgDoc
forall (a :: Pass) body. Stmt (GhcPass a) body -> MsgDoc
pprStmtCat StmtLR GhcPs GhcPs (Located (body GhcPs))
stmt MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"statement")
             , String -> MsgDoc
text String
"in" MsgDoc -> MsgDoc -> MsgDoc
<+> HsStmtContext Name -> MsgDoc
forall id.
(Outputable id, Outputable (NameOrRdrName id)) =>
HsStmtContext id -> MsgDoc
pprAStmtContext HsStmtContext Name
ctxt ]

pprStmtCat :: Stmt (GhcPass a) body -> SDoc
pprStmtCat :: Stmt (GhcPass a) body -> MsgDoc
pprStmtCat (TransStmt {})     = String -> MsgDoc
text String
"transform"
pprStmtCat (LastStmt {})      = String -> MsgDoc
text String
"return expression"
pprStmtCat (BodyStmt {})      = String -> MsgDoc
text String
"body"
pprStmtCat (BindStmt {})      = String -> MsgDoc
text String
"binding"
pprStmtCat (LetStmt {})       = String -> MsgDoc
text String
"let"
pprStmtCat (RecStmt {})       = String -> MsgDoc
text String
"rec"
pprStmtCat (ParStmt {})       = String -> MsgDoc
text String
"parallel"
pprStmtCat (ApplicativeStmt {}) = String -> MsgDoc
forall a. String -> a
panic String
"pprStmtCat: ApplicativeStmt"
pprStmtCat (XStmtLR XXStmtLR (GhcPass a) (GhcPass a) body
nec)        = NoExtCon -> MsgDoc
forall a. NoExtCon -> a
noExtCon XXStmtLR (GhcPass a) (GhcPass a) body
NoExtCon
nec

------------
emptyInvalid :: Validity  -- Payload is the empty document
emptyInvalid :: Validity
emptyInvalid = MsgDoc -> Validity
NotValid MsgDoc
Outputable.empty

okStmt, okDoStmt, okCompStmt, okParStmt
   :: DynFlags -> HsStmtContext Name
   -> Stmt GhcPs (Located (body GhcPs)) -> Validity
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to a generic error message

okStmt :: DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
  = case HsStmtContext Name
ctxt of
      PatGuard {}        -> Stmt GhcPs (Located (body GhcPs)) -> Validity
forall (body :: * -> *).
Stmt GhcPs (Located (body GhcPs)) -> Validity
okPatGuardStmt Stmt GhcPs (Located (body GhcPs))
stmt
      ParStmtCtxt HsStmtContext Name
ctxt   -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okParStmt  DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
DoExpr             -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okDoStmt   DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
MDoExpr            -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okDoStmt   DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
ArrowExpr          -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okDoStmt   DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
GhciStmtCtxt       -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okDoStmt   DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
ListComp           -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      HsStmtContext Name
MonadComp          -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
      TransStmtCtxt HsStmtContext Name
ctxt -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt

-------------
okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
okPatGuardStmt Stmt GhcPs (Located (body GhcPs))
stmt
  = case Stmt GhcPs (Located (body GhcPs))
stmt of
      BodyStmt {} -> Validity
IsValid
      BindStmt {} -> Validity
IsValid
      LetStmt {}  -> Validity
IsValid
      Stmt GhcPs (Located (body GhcPs))
_           -> Validity
emptyInvalid

-------------
okParStmt :: DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okParStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
  = case Stmt GhcPs (Located (body GhcPs))
stmt of
      LetStmt XLetStmt GhcPs GhcPs (Located (body GhcPs))
_ (L SrcSpan
_ (HsIPBinds {})) -> Validity
emptyInvalid
      Stmt GhcPs (Located (body GhcPs))
_                              -> DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
forall (body :: * -> *).
DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt

----------------
okDoStmt :: DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext Name
ctxt Stmt GhcPs (Located (body GhcPs))
stmt
  = case Stmt GhcPs (Located (body GhcPs))
stmt of
       RecStmt {}
         | Extension
LangExt.RecursiveDo Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity
IsValid
         | HsStmtContext Name
ArrowExpr <- HsStmtContext Name
ctxt -> Validity
IsValid    -- Arrows allows 'rec'
         | Bool
otherwise         -> MsgDoc -> Validity
NotValid (String -> MsgDoc
text String
"Use RecursiveDo")
       BindStmt {} -> Validity
IsValid
       LetStmt {}  -> Validity
IsValid
       BodyStmt {} -> Validity
IsValid
       Stmt GhcPs (Located (body GhcPs))
_           -> Validity
emptyInvalid

----------------
okCompStmt :: DynFlags
-> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext Name
_ Stmt GhcPs (Located (body GhcPs))
stmt
  = case Stmt GhcPs (Located (body GhcPs))
stmt of
       BindStmt {} -> Validity
IsValid
       LetStmt {}  -> Validity
IsValid
       BodyStmt {} -> Validity
IsValid
       ParStmt {}
         | Extension
LangExt.ParallelListComp Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity
IsValid
         | Bool
otherwise -> MsgDoc -> Validity
NotValid (String -> MsgDoc
text String
"Use ParallelListComp")
       TransStmt {}
         | Extension
LangExt.TransformListComp Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity
IsValid
         | Bool
otherwise -> MsgDoc -> Validity
NotValid (String -> MsgDoc
text String
"Use TransformListComp")
       RecStmt {}  -> Validity
emptyInvalid
       LastStmt {} -> Validity
emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
       ApplicativeStmt {} -> Validity
emptyInvalid
       XStmtLR XXStmtLR GhcPs GhcPs (Located (body GhcPs))
nec -> NoExtCon -> Validity
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcPs GhcPs (Located (body GhcPs))
NoExtCon
nec

---------
checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
checkTupleSection :: [LHsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [LHsTupArg GhcPs]
args
  = do  { Bool
tuple_section <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TupleSections
        ; Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkErr ((LHsTupArg GhcPs -> Bool) -> [LHsTupArg GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcPs -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcPs]
args Bool -> Bool -> Bool
|| Bool
tuple_section) MsgDoc
msg }
  where
    msg :: MsgDoc
msg = String -> MsgDoc
text String
"Illegal tuple section: use TupleSections"

---------
sectionErr :: HsExpr GhcPs -> SDoc
sectionErr :: HsExpr GhcPs -> MsgDoc
sectionErr HsExpr GhcPs
expr
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"A section must be enclosed in parentheses")
       Int
2 (String -> MsgDoc
text String
"thus:" MsgDoc -> MsgDoc -> MsgDoc
<+> (MsgDoc -> MsgDoc
parens (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
expr)))

badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds :: MsgDoc -> a -> MsgDoc
badIpBinds MsgDoc
what a
binds
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Implicit-parameter bindings illegal in" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
what)
         Int
2 (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
binds)

---------

monadFailOp :: LPat GhcPs
            -> HsStmtContext Name
            -> RnM (SyntaxExpr GhcRn, FreeVars)
monadFailOp :: LPat GhcPs
-> HsStmtContext Name -> RnM (SyntaxExpr GhcRn, FreeVars)
monadFailOp LPat GhcPs
pat HsStmtContext Name
ctxt
  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
  -- we should not need to fail.
  | LPat GhcPs -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
isIrrefutableHsPat LPat GhcPs
pat = (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)

  -- For non-monadic contexts (e.g. guard patterns, list
  -- comprehensions, etc.) we should not need to fail.  See Note
  -- [Failing pattern matches in Stmts]
  | Bool -> Bool
not (HsStmtContext Name -> Bool
forall id. HsStmtContext id -> Bool
isMonadFailStmtContext HsStmtContext Name
ctxt) = (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)

  | Bool
otherwise = RnM (SyntaxExpr GhcRn, FreeVars)
getMonadFailOp

{-
Note [Monad fail : Rebindable syntax, overloaded strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Given the code
  foo x = do { Just y <- x; return y }

we expect it to desugar as
  foo x = x >>= \r -> case r of
                        Just y  -> return y
                        Nothing -> fail "Pattern match error"

But with RebindableSyntax and OverloadedStrings, we really want
it to desugar thus:
  foo x = x >>= \r -> case r of
                        Just y  -> return y
                        Nothing -> fail (fromString "Patterm match error")

So, in this case, we synthesize the function
  \x -> fail (fromString x)

(rather than plain 'fail') for the 'fail' operation. This is done in
'getMonadFailOp'.
-}
getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars)
getMonadFailOp
 = do { Bool
xOverloadedStrings <- (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings) IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      ; Bool
xRebindableSyntax <- (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RebindableSyntax) IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      ; Bool -> Bool -> RnM (SyntaxExpr GhcRn, FreeVars)
reallyGetMonadFailOp Bool
xRebindableSyntax Bool
xOverloadedStrings
      }
  where
    reallyGetMonadFailOp :: Bool -> Bool -> RnM (SyntaxExpr GhcRn, FreeVars)
reallyGetMonadFailOp Bool
rebindableSyntax Bool
overloadedStrings
      | Bool
rebindableSyntax Bool -> Bool -> Bool
&& Bool
overloadedStrings = do
        (SyntaxExpr GhcRn
failExpr, FreeVars
failFvs) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
failMName
        (SyntaxExpr GhcRn
fromStringExpr, FreeVars
fromStringFvs) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
fromStringName
        let arg_lit :: FastString
arg_lit = String -> FastString
fsLit String
"arg"
            arg_name :: Name
arg_name = Unique -> FastString -> Name
mkSystemVarName (FastString -> Unique
mkVarOccUnique FastString
arg_lit) FastString
arg_lit
            arg_syn_expr :: SyntaxExpr GhcRn
arg_syn_expr = Name -> SyntaxExpr GhcRn
mkRnSyntaxExpr Name
arg_name
        let LHsExpr GhcRn
body :: LHsExpr GhcRn =
              LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. SyntaxExpr p -> HsExpr p
syn_expr SyntaxExpr GhcRn
failExpr)
                      (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. SyntaxExpr p -> HsExpr p
syn_expr SyntaxExpr GhcRn
fromStringExpr)
                                (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. SyntaxExpr p -> HsExpr p
syn_expr SyntaxExpr GhcRn
arg_syn_expr))
        let HsExpr GhcRn
failAfterFromStringExpr :: HsExpr GhcRn =
              LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn))
-> LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ [LPat GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (p :: Pass).
(XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [SrcSpanLess (Located (Pat GhcRn)) -> Located (Pat GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcRn)) -> Located (Pat GhcRn))
-> SrcSpanLess (Located (Pat GhcRn)) -> Located (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcRn -> Located (IdP GhcRn) -> Pat GhcRn
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcRn
NoExtField
noExtField (Located (IdP GhcRn) -> Pat GhcRn)
-> Located (IdP GhcRn) -> Pat GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (Located Name)
arg_name] LHsExpr GhcRn
body
        let SyntaxExpr GhcRn
failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
              HsExpr GhcRn -> SyntaxExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p)
mkSyntaxExpr HsExpr GhcRn
failAfterFromStringExpr
        (SyntaxExpr GhcRn, FreeVars) -> RnM (SyntaxExpr GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
failAfterFromStringSynExpr, FreeVars
failFvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fromStringFvs)
      | Bool
otherwise = Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntaxName Name
failMName