{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Expr (
rnLExpr, rnExpr, rnStmts,
AnnoBody
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
, rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Hs
import GHC.Tc.Utils.Env ( isBrackStage )
import GHC.Tc.Utils.Monad
import GHC.Unit.Module ( getModule )
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
, bindLocalNames
, mapMaybeFvRn, mapFvRn
, warnUnusedLocalBinds, typeAppErr
, checkUnusedRecordWildcard )
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
import GHC.Rename.Pat
import GHC.Driver.Session
import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Fixity
import GHC.Types.Id.Make
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.List.SetOps ( removeDups )
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc
import GHC.Data.FastString
import Control.Monad
import GHC.Builtin.Types ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
import Data.List (unzip4, minimumBy)
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs :: [LHsExpr GhcPs] -> RnM ([XRec GhcRn (HsExpr GhcRn)], FreeVars)
rnExprs [LHsExpr GhcPs]
ls = [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
rnExprs' [LHsExpr GhcPs]
ls forall a. UniqSet a
emptyUniqSet
where
rnExprs' :: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
rnExprs' [] FreeVars
acc = forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
acc)
rnExprs' (GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr:[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
exprs) FreeVars
acc =
do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
; let acc' :: FreeVars
acc' = FreeVars
acc FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr
; ([GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs', FreeVars
fvExprs) <- FreeVars
acc' seq :: forall a b. a -> b -> b
`seq` [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
rnExprs' [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
exprs FreeVars
acc'
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'forall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exprs', FreeVars
fvExprs) }
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr :: LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr = forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (L SrcSpanAnnA
l Name
name)
= do { Module
this_mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) forall a b. (a -> b) -> a -> b
$
Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkThLocalName Name
name
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpanAnnN
la2na SrcSpanAnnA
l) Name
name), Name -> FreeVars
unitFV Name
name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
v =
if RdrName -> Bool
isUnqual RdrName
v
then
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar NoExtField
noExtField (RdrName -> OccName
rdrNameOcc RdrName
v), FreeVars
emptyFVs)
else
do { Name
n <- RdrName -> RnM Name
reportUnboundName RdrName
v
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Name
n), FreeVars
emptyFVs) }
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (HsVar XVar GhcPs
_ (L SrcSpanAnnN
l RdrName
v))
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let dup_fields_ok :: DuplicateRecordFields
dup_fields_ok = DynFlags -> DuplicateRecordFields
xopt_DuplicateRecordFields DynFlags
dflags
; Maybe AmbiguousResult
mb_name <- DuplicateRecordFields -> RdrName -> RnM (Maybe AmbiguousResult)
lookupExprOccRn DuplicateRecordFields
dup_fields_ok RdrName
v
; case Maybe AmbiguousResult
mb_name of {
Maybe AmbiguousResult
Nothing -> RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
v ;
Just (UnambiguousGre (NormalGreName Name
name))
| Name
name forall a. Eq a => a -> a -> Bool
== Name
nilDataConName
, Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedLists DynFlags
dflags
-> HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList forall a. EpAnn a
noAnn [])
| Bool
otherwise
-> LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
l) Name
name) ;
Just (UnambiguousGre (FieldGreName FieldLabel
fl)) ->
let sel_name :: Name
sel_name = FieldLabel -> Name
flSelector FieldLabel
fl in
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XUnambiguous pass
-> GenLocated SrcSpanAnnN RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
sel_name (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v) ), Name -> FreeVars
unitFV Name
sel_name) ;
Just AmbiguousResult
AmbiguousFields ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
noExtField (forall pass.
XAmbiguous pass
-> GenLocated SrcSpanAnnN RdrName -> AmbiguousFieldOcc pass
Ambiguous NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l RdrName
v) ), FreeVars
emptyFVs) } }
rnExpr (HsIPVar XIPVar GhcPs
x HsIPName
v)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar XIPVar GhcPs
x HsIPName
v, FreeVars
emptyFVs)
rnExpr (HsUnboundVar XUnboundVar GhcPs
_ OccName
v)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XUnboundVar p -> OccName -> HsExpr p
HsUnboundVar NoExtField
noExtField OccName
v, FreeVars
emptyFVs)
rnExpr (HsOverLabel XOverLabel GhcPs
_ FastString
v)
= do { (Name
from_label, FreeVars
fvs) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
fromLabelClassOpName
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr (forall p. XOverLabel p -> FastString -> HsExpr p
HsOverLabel forall a. EpAnn a
noAnn FastString
v) forall a b. (a -> b) -> a -> b
$
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
noExtField (Name -> XRec GhcRn (HsExpr GhcRn)
genLHsVar Name
from_label) HsWildCardBndrs GhcRn (LocatedAn AnnListItem (HsType GhcRn))
hs_ty_arg
, FreeVars
fvs ) }
where
hs_ty_arg :: HsWildCardBndrs GhcRn (LocatedAn AnnListItem (HsType GhcRn))
hs_ty_arg = forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
noExtField (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
v)
rnExpr (HsLit XLitE GhcPs
x lit :: HsLit GhcPs
lit@(HsString XHsString GhcPs
src FastString
s))
= do { Bool
opt_OverloadedStrings <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
; if Bool
opt_OverloadedStrings then
HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XLitE GhcPs
x (SourceText -> FastString -> HsOverLit GhcPs
mkHsIsString XHsString GhcPs
src FastString
s))
else do {
; forall p. HsLit p -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnLit HsLit GhcPs
lit
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
x (forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcPs
lit), FreeVars
emptyFVs) } }
rnExpr (HsLit XLitE GhcPs
x HsLit GhcPs
lit)
= do { forall p. HsLit p -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnLit HsLit GhcPs
lit
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
x(forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
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) <- forall t.
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit GhcPs
lit
; case Maybe (HsExpr GhcRn)
mb_neg of
Maybe (HsExpr GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
x HsOverLit GhcRn
lit', FreeVars
fvs)
Just HsExpr GhcRn
neg ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
neg) (forall a an. a -> LocatedAn an a
noLocA (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
x HsOverLit GhcRn
lit'))
, FreeVars
fvs ) }
rnExpr (HsApp XApp GhcPs
x LHsExpr GhcPs
fun LHsExpr GhcPs
arg)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun',FreeVars
fvFun) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
fun
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun' GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }
rnExpr (HsAppType XAppTypeE GhcPs
_ LHsExpr GhcPs
fun LHsWcType (NoGhcTc GhcPs)
arg)
= do { Bool
type_app <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
type_app forall a b. (a -> b) -> a -> b
$ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs -> SDoc
typeAppErr String
"type" forall a b. (a -> b) -> a -> b
$ forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsWcType (NoGhcTc GhcPs)
arg
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun',FreeVars
fvFun) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
fun
; (HsWildCardBndrs GhcRn (LocatedAn AnnListItem (HsType GhcRn))
arg',FreeVars
fvArg) <- HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
HsTypeCtx LHsWcType (NoGhcTc GhcPs)
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
NoExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun' HsWildCardBndrs GhcRn (LocatedAn AnnListItem (HsType GhcRn))
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }
rnExpr (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
e1 LHsExpr GhcPs
op LHsExpr GhcPs
e2)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1', FreeVars
fv_e1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e1
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2', FreeVars
fv_e2) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e2
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
op', FreeVars
fv_op) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op
; Fixity
fixity <- case GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' of
L SrcSpanAnnA
_ (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
n)) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
n
L SrcSpanAnnA
_ (HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f) -> AmbiguousFieldOcc GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFieldFixityRn AmbiguousFieldOcc GhcRn
f
GenLocated SrcSpanAnnA (HsExpr GhcRn)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
NoSourceText Int
minPrecedence FixityDirection
InfixL)
; Bool
lexical_negation <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.LexicalNegation
; let negation_handling :: NegationHandling
negation_handling | Bool
lexical_negation = NegationHandling
KeepNegationIntact
| Bool
otherwise = NegationHandling
ReassociateNegation
; HsExpr GhcRn
final_e <- NegationHandling
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> Fixity
-> XRec GhcRn (HsExpr GhcRn)
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
negation_handling GenLocated SrcSpanAnnA (HsExpr GhcRn)
e1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' Fixity
fixity GenLocated SrcSpanAnnA (HsExpr GhcRn)
e2'
; 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 { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e', FreeVars
fv_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; (SyntaxExprRn
neg_name, FreeVars
fv_neg) <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
negateName
; HsExpr GhcRn
final_e <- XRec GhcRn (HsExpr GhcRn) -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
mkNegAppRn GenLocated SrcSpanAnnA (HsExpr GhcRn)
e' SyntaxExprRn
neg_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
final_e, FreeVars
fv_e FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_neg) }
rnExpr (HsGetField XGetField GhcPs
_ LHsExpr GhcPs
e Located (HsFieldLabel GhcPs)
f)
= do { (Name
getField, FreeVars
fv_getField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
getFieldName
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e, FreeVars
fv_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; let f' :: Located (HsFieldLabel GhcRn)
f' = Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
rnHsFieldLabel Located (HsFieldLabel GhcPs)
f
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr
(forall p.
XGetField p -> LHsExpr p -> Located (HsFieldLabel p) -> HsExpr p
HsGetField NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
e Located (HsFieldLabel GhcRn)
f')
(Name
-> XRec GhcRn (HsExpr GhcRn) -> Located FastString -> HsExpr GhcRn
mkGetField Name
getField GenLocated SrcSpanAnnA (HsExpr GhcRn)
e (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsFieldLabel p -> Located FastString
hflLabel) Located (HsFieldLabel GhcRn)
f'))
, FreeVars
fv_e FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_getField ) }
rnExpr (HsProjection XProjection GhcPs
_ NonEmpty (Located (HsFieldLabel GhcPs))
fs)
= do { (Name
getField, FreeVars
fv_getField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
getFieldName
; Name
circ <- RdrName -> RnM Name
lookupOccRn RdrName
compose_RDR
; let fs' :: NonEmpty (Located (HsFieldLabel GhcRn))
fs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
rnHsFieldLabel NonEmpty (Located (HsFieldLabel GhcPs))
fs
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr
(forall p.
XProjection p -> NonEmpty (Located (HsFieldLabel p)) -> HsExpr p
HsProjection NoExtField
noExtField NonEmpty (Located (HsFieldLabel GhcRn))
fs')
(Name -> Name -> NonEmpty (Located FastString) -> HsExpr GhcRn
mkProjection Name
getField Name
circ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsFieldLabel p -> Located FastString
hflLabel)) NonEmpty (Located (HsFieldLabel GhcRn))
fs'))
, Name -> FreeVars
unitFV Name
circ FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_getField) }
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
rnExpr (HsPar XPar GhcPs
x (L SrcSpanAnnA
loc (section :: HsExpr GhcPs
section@(SectionL {}))))
= do { (HsExpr GhcRn
section', FreeVars
fvs) <- HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcRn
section'), FreeVars
fvs) }
rnExpr (HsPar XPar GhcPs
x (L SrcSpanAnnA
loc (section :: HsExpr GhcPs
section@(SectionR {}))))
= do { (HsExpr GhcRn
section', FreeVars
fvs) <- HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
x (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcRn
section'), FreeVars
fvs) }
rnExpr (HsPar XPar GhcPs
x LHsExpr GhcPs
e)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e', FreeVars
fvs_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
e', FreeVars
fvs_e) }
rnExpr expr :: HsExpr GhcPs
expr@(SectionL {})
= do { SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> SDoc
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }
rnExpr expr :: HsExpr GhcPs
expr@(SectionR {})
= do { SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> SDoc
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }
rnExpr (HsPragE XPragE GhcPs
x HsPragE GhcPs
prag LHsExpr GhcPs
expr)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcPs
x (HsPragE GhcPs -> HsPragE GhcRn
rn_prag HsPragE GhcPs
prag) GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs_expr) }
where
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag (HsPragSCC XSCC GhcPs
x1 SourceText
src StringLiteral
ann) = forall p. XSCC p -> SourceText -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcPs
x1 SourceText
src StringLiteral
ann
rnExpr (HsLam XLam GhcPs
x MatchGroup GhcPs (LHsExpr GhcPs)
matches)
= do { (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches', FreeVars
fvMatch) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup forall p. HsMatchContext p
LambdaExpr LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcPs
x MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches', FreeVars
fvMatch) }
rnExpr (HsLamCase XLamCase GhcPs
x MatchGroup GhcPs (LHsExpr GhcPs)
matches)
= do { (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches', FreeVars
fvs_ms) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup forall p. HsMatchContext p
CaseAlt LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcPs
x MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
matches', FreeVars
fvs_ms) }
rnExpr (HsCase XCase GhcPs
_ LHsExpr GhcPs
expr MatchGroup GhcPs (LHsExpr GhcPs)
matches)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
new_expr, FreeVars
e_fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
new_matches, FreeVars
ms_fvs) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup forall p. HsMatchContext p
CaseAlt LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
new_expr MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
new_matches, FreeVars
e_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
ms_fvs) }
rnExpr (HsLet XLet GhcPs
_ HsLocalBinds GhcPs
binds LHsExpr GhcPs
expr)
= forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
_ -> do
{ (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr',FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet NoExtField
noExtField HsLocalBinds GhcRn
binds' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr) }
rnExpr (HsDo XDo GhcPs
_ HsStmtContext (HsDoRn GhcPs)
do_or_lc (L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))
= do { (([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts', ()
_), FreeVars
fvs) <-
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> (HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext (HsDoRn GhcPs)
do_or_lc HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr
HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts
(\ [Name]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo NoExtField
noExtField HsStmtContext (HsDoRn GhcPs)
do_or_lc (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts'), FreeVars
fvs ) }
rnExpr (ExplicitList XExplicitList GhcPs
_ [LHsExpr GhcPs]
exps)
= do { ([GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exps', FreeVars
fvs) <- [LHsExpr GhcPs] -> RnM ([XRec GhcRn (HsExpr GhcRn)], FreeVars)
rnExprs [LHsExpr GhcPs]
exps
; Bool
opt_OverloadedLists <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
; if Bool -> Bool
not Bool
opt_OverloadedLists
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
noExtField [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exps', FreeVars
fvs)
else
do { (Name
from_list_n_name, FreeVars
fvs') <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
fromListNName
; let rn_list :: HsExpr GhcRn
rn_list = forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList NoExtField
noExtField [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exps'
lit_n :: IntegralLit
lit_n = forall a. Integral a => a -> IntegralLit
mkIntegralLit (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
exps)
hs_lit :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hs_lit = forall a an. a -> LocatedAn an a
wrapGenSpan (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn (forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField IntegralLit
lit_n))
exp_list :: HsExpr GhcRn
exp_list = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
from_list_n_name [GenLocated SrcSpanAnnA (HsExpr GhcRn)
hs_lit, forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
rn_list]
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
rn_list HsExpr GhcRn
exp_list
, FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs') } }
rnExpr (ExplicitTuple XExplicitTuple GhcPs
_ [HsTupArg GhcPs]
tup_args Boxity
boxity)
= do { [HsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [HsTupArg GhcPs]
tup_args
; ([HsTupArg GhcRn]
tup_args', [FreeVars]
fvs) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM HsTupArg GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcRn, FreeVars)
rnTupArg [HsTupArg GhcPs]
tup_args
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple NoExtField
noExtField [HsTupArg GhcRn]
tup_args' Boxity
boxity, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvs) }
where
rnTupArg :: HsTupArg GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcRn, FreeVars)
rnTupArg (Present XPresent GhcPs
x LHsExpr GhcPs
e) = do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e',FreeVars
fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
e', FreeVars
fvs) }
rnTupArg (Missing XMissing GhcPs
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XMissing id -> HsTupArg id
Missing NoExtField
noExtField, FreeVars
emptyFVs)
rnExpr (ExplicitSum XExplicitSum GhcPs
_ Int
alt Int
arity LHsExpr GhcPs
expr)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum NoExtField
noExtField Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs) }
rnExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = XRec GhcPs (ConLikeP 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 :: GenLocated SrcSpanAnnN Name
con_lname@(L SrcSpanAnnN
_ Name
con_name) <- forall ann.
GenLocated (SrcSpanAnn' ann) RdrName
-> TcRn (GenLocated (SrcSpanAnn' ann) Name)
lookupLocatedOccRn XRec GhcPs (ConLikeP GhcPs)
con_id
; ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds, FreeVars
fvs) <- forall arg.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields GhcPs (LocatedA arg)
-> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
rnHsRecFields (Name -> HsRecFieldContext
HsRecFieldCon Name
con_name) forall {p} {ann}.
(XVar p ~ NoExtField,
XRec p (IdP p) ~ GenLocated (SrcAnn ann) (IdP p)) =>
SrcSpan -> IdP p -> HsExpr p
mk_hs_var HsRecordBinds GhcPs
rec_binds
; ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds', [FreeVars]
fvss) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM forall {l} {id}.
GenLocated
l (HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
l (HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
rn_field [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds
; let rec_binds' :: HsRecFields GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
rec_binds' = HsRecFields { rec_flds :: [LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
rec_flds = [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds', rec_dotdot :: Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
dd }
; forall (m :: * -> *) a. Monad m => a -> m a
return (RecordCon { rcon_ext :: XRecordCon GhcRn
rcon_ext = NoExtField
noExtField
, rcon_con :: XRec GhcRn (ConLikeP GhcRn)
rcon_con = GenLocated SrcSpanAnnN Name
con_lname, rcon_flds :: HsRecordBinds GhcRn
rcon_flds = HsRecFields GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 = forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l) IdP p
n)
rn_field :: GenLocated
l (HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
l (HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
rn_field (L l
l HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld) = do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg', FreeVars
fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr (forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L l
l (HsRecField' id (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld { hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr 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 -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
rbinds })
= case Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
rbinds of
Left [LHsRecUpdField GhcPs]
flds ->
do { ; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e, FreeVars
fv_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; ([GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rs, FreeVars
fv_rs) <- [LHsRecUpdField GhcPs] -> RnM ([LHsRecUpdField GhcRn], FreeVars)
rnHsRecUpdFields [LHsRecUpdField GhcPs]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
e (forall a b. a -> Either a b
Left [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rs), FreeVars
fv_e FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fv_rs )
}
Right [LHsRecUpdProj GhcPs]
flds ->
do { ; forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.RebindableSyntax forall a b. (a -> b) -> a -> b
$
SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"RebindableSyntax is required if OverloadedRecordUpdate is enabled."
; let punnedFields :: [HsRecField'
(FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
punnedFields = [HsRecField'
(FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld | (L SrcSpanAnnA
_ HsRecField'
(FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld) <- [LHsRecUpdProj GhcPs]
flds, forall id arg. HsRecField' id arg -> Bool
hsRecPun HsRecField'
(FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld]
; Bool
punsEnabled <-forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RecordPuns
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsRecField'
(FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
punnedFields Bool -> Bool -> Bool
|| Bool
punsEnabled) forall a b. (a -> b) -> a -> b
$
SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"For this to work enable NamedFieldPuns."
; (Name
getField, FreeVars
fv_getField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
getFieldName
; (Name
setField, FreeVars
fv_setField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
setFieldName
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
e, FreeVars
fv_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
us, FreeVars
fv_us) <- [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
rnHsUpdProjs [LHsRecUpdProj GhcPs]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr
(forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
e (forall a b. b -> Either a b
Right [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
us))
(Name
-> Name
-> XRec GhcRn (HsExpr GhcRn)
-> [LHsRecUpdProj GhcRn]
-> HsExpr GhcRn
mkRecordDotUpd Name
getField Name
setField GenLocated SrcSpanAnnA (HsExpr GhcRn)
e [GenLocated
SrcSpanAnnA
(HsRecField'
(FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
us)
, [FreeVars] -> FreeVars
plusFVs [FreeVars
fv_getField, FreeVars
fv_setField, FreeVars
fv_e, FreeVars
fv_us] )
}
rnExpr (ExprWithTySig XExprWithTySig GhcPs
_ LHsExpr GhcPs
expr LHsSigWcType (NoGhcTc GhcPs)
pty)
= do { (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
pty', FreeVars
fvTy) <- HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
ExprWithTySigCtx LHsSigWcType (NoGhcTc GhcPs)
pty
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr) <- forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV (LHsSigWcType GhcRn -> [Name]
hsWcScopedTvs HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
pty') forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr' HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
pty', FreeVars
fvExpr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvTy) }
rnExpr (HsIf XIf GhcPs
_ LHsExpr GhcPs
p LHsExpr GhcPs
b1 LHsExpr GhcPs
b2)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
p', FreeVars
fvP) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
p
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
b1', FreeVars
fvB1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
b1
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
b2', FreeVars
fvB2) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
b2
; let fvs_if :: FreeVars
fvs_if = [FreeVars] -> FreeVars
plusFVs [FreeVars
fvP, FreeVars
fvB1, FreeVars
fvB2]
rn_if :: HsExpr GhcRn
rn_if = forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
p' GenLocated SrcSpanAnnA (HsExpr GhcRn)
b1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
b2'
; Maybe Name
mb_ite <- RnM (Maybe Name)
lookupIfThenElse
; case Maybe Name
mb_ite of
Maybe Name
Nothing
-> forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
rn_if, FreeVars
fvs_if)
Just Name
ite_name
-> do { let ds_if :: HsExpr GhcRn
ds_if = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
ite_name [GenLocated SrcSpanAnnA (HsExpr GhcRn)
p', GenLocated SrcSpanAnnA (HsExpr GhcRn)
b1', GenLocated SrcSpanAnnA (HsExpr GhcRn)
b2']
fvs :: FreeVars
fvs = [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs_if, Name -> FreeVars
unitFV Name
ite_name]
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
rn_if HsExpr GhcRn
ds_if, FreeVars
fvs) } }
rnExpr (HsMultiIf XMultiIf GhcPs
_ [LGRHS GhcPs (LHsExpr GhcPs)]
alts)
= do { ([GenLocated
(Anno (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts', FreeVars
fvs) <- forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (forall (body :: * -> *).
AnnoBody body =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS forall p. HsMatchContext p
IfAlt LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr) [LGRHS GhcPs (LHsExpr GhcPs)]
alts
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf NoExtField
noExtField [GenLocated
(Anno (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
alts', FreeVars
fvs) }
rnExpr (ArithSeq XArithSeq GhcPs
_ Maybe (SyntaxExpr GhcPs)
_ ArithSeqInfo GhcPs
seq)
= do { Bool
opt_OverloadedLists <- 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 {
; (SyntaxExprRn
from_list_name, FreeVars
fvs') <- Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
fromListName
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq NoExtField
noExtField (forall a. a -> Maybe a
Just SyntaxExprRn
from_list_name) ArithSeqInfo GhcRn
new_seq
, FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs') }
else
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq NoExtField
noExtField forall a. Maybe a
Nothing ArithSeqInfo GhcRn
new_seq, FreeVars
fvs) }
rnExpr e :: HsExpr GhcPs
e@(HsStatic XStatic GhcPs
_ LHsExpr GhcPs
expr) = do
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.StaticPointers forall a b. (a -> b) -> a -> b
$
SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal static expression:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e)
Int
2 (String -> SDoc
text String
"Use StaticPointers to enable this extension")
(GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr',FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
ThStage
stage <- TcM ThStage
getStage
case ThStage
stage of
Splice SpliceType
_ -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
[ String -> SDoc
text String
"static forms cannot be used in splices:"
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
e
]
ThStage
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
let fvExpr' :: FreeVars
fvExpr' = (Name -> Bool) -> FreeVars -> FreeVars
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) FreeVars
fvExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic FreeVars
fvExpr' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr)
rnExpr (HsProc XProc GhcPs
x LPat GhcPs
pat LHsCmdTop GhcPs
body)
= forall a. TcM a -> TcM a
newArrowScope forall a b. (a -> b) -> a -> b
$
forall a.
HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat (forall p. HsArrowMatchContext -> HsMatchContext p
ArrowMatchCtxt HsArrowMatchContext
ProcExpr) LPat GhcPs
pat forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
pat' -> do
{ (GenLocated SrcSpan (HsCmdTop GhcRn)
body',FreeVars
fvBody) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
body
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcPs
x LPat GhcRn
pat' GenLocated SrcSpan (HsCmdTop GhcRn)
body', FreeVars
fvBody) }
rnExpr HsExpr GhcPs
other = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnExpr: unexpected expression" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
other)
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 { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
op', FreeVars
fvs_op) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; FixityDirection
-> HsExpr GhcPs
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkSectionPrec FixityDirection
InfixR HsExpr GhcPs
section GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
; let rn_section :: HsExpr GhcRn
rn_section = forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
ds_section :: HsExpr GhcRn
ds_section = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
rightSectionName [GenLocated SrcSpanAnnA (HsExpr GhcRn)
op',GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr']
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
rn_section HsExpr GhcRn
ds_section
, 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 { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvs_expr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
op', FreeVars
fvs_op) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op
; FixityDirection
-> HsExpr GhcPs
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkSectionPrec FixityDirection
InfixL HsExpr GhcPs
section GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
; Bool
postfix_ops <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PostfixOperators
; let rn_section :: HsExpr GhcRn
rn_section = forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr' GenLocated SrcSpanAnnA (HsExpr GhcRn)
op'
ds_section :: HsExpr GhcRn
ds_section
| Bool
postfix_ops = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
| Bool
otherwise = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
leftSectionName
[forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr']
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
rn_section HsExpr GhcRn
ds_section
, FreeVars
fvs_op FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_expr) }
rnSection HsExpr GhcPs
other = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSection" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
other)
rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
rnHsFieldLabel (L SrcSpan
l (HsFieldLabel XCHsFieldLabel GhcPs
x Located FastString
label)) = forall l e. l -> e -> GenLocated l e
L SrcSpan
l (forall p. XCHsFieldLabel p -> Located FastString -> HsFieldLabel p
HsFieldLabel XCHsFieldLabel GhcPs
x Located FastString
label)
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings (FieldLabelStrings [Located (HsFieldLabel GhcPs)]
fls) = forall p. [Located (HsFieldLabel p)] -> FieldLabelStrings p
FieldLabelStrings (forall a b. (a -> b) -> [a] -> [b]
map Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)
rnHsFieldLabel [Located (HsFieldLabel GhcPs)]
fls)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyFVs)
rnCmdArgs (LHsCmdTop GhcPs
arg:[LHsCmdTop GhcPs]
args)
= do { (GenLocated SrcSpan (HsCmdTop GhcRn)
arg',FreeVars
fvArg) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg
; ([GenLocated SrcSpan (HsCmdTop GhcRn)]
args',FreeVars
fvArgs) <- [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [LHsCmdTop GhcPs]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (HsCmdTop GhcRn)
arg'forall a. a -> [a] -> [a]
:[GenLocated SrcSpan (HsCmdTop 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 = forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop'
where
rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' (HsCmdTop XCmdTop GhcPs
_ LHsCmd GhcPs
cmd)
= do { (GenLocated SrcSpanAnnA (HsCmd 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] forall a. [a] -> [a] -> [a]
++
FreeVars -> [Name]
nameSetElemsStable (HsCmd GhcRn -> FreeVars
methodNamesCmd (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsCmd GhcRn)
cmd'))
; ([HsExpr GhcRn]
cmd_names', FreeVars
cmd_fvs) <- [Name] -> RnM ([HsExpr GhcRn], FreeVars)
lookupSyntaxNames [Name]
cmd_names
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop ([Name]
cmd_names forall a b. [a] -> [b] -> [(a, b)]
`zip` [HsExpr GhcRn]
cmd_names') GenLocated SrcSpanAnnA (HsCmd GhcRn)
cmd',
FreeVars
fvCmd FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
cmd_fvs) }
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA 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
_ LHsExpr GhcPs
arrow LHsExpr GhcPs
arg HsArrAppType
ho Bool
rtl)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arrow',FreeVars
fvArrow) <- TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
select_arrow_scope (LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arrow)
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdArrApp id
-> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id
HsCmdArrApp NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
arrow' GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg' HsArrAppType
ho Bool
rtl,
FreeVars
fvArrow FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }
where
select_arrow_scope :: TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
select_arrow_scope TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc = case HsArrAppType
ho of
HsArrAppType
HsHigherOrderApp -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc
HsArrAppType
HsFirstOrderApp -> forall a. TcM a -> TcM a
escapeArrowScope TcM (GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc
rnCmd (HsCmdArrForm XCmdArrForm GhcPs
_ LHsExpr GhcPs
op LexicalFixity
_ (Just Fixity
_) [LHsCmdTop GhcPs
arg1, LHsCmdTop GhcPs
arg2])
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
op',FreeVars
fv_op) <- forall a. TcM a -> TcM a
escapeArrowScope (LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op)
; let L SrcSpanAnnA
_ (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
op_name)) = GenLocated SrcSpanAnnA (HsExpr GhcRn)
op'
; (GenLocated SrcSpan (HsCmdTop GhcRn)
arg1',FreeVars
fv_arg1) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg1
; (GenLocated SrcSpan (HsCmdTop GhcRn)
arg2',FreeVars
fv_arg2) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg2
; Fixity
fixity <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
op_name
; HsCmd GhcRn
final_e <- LHsCmdTop GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> Fixity
-> LHsCmdTop GhcRn
-> RnM (HsCmd GhcRn)
mkOpFormRn GenLocated SrcSpan (HsCmdTop GhcRn)
arg1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' Fixity
fixity GenLocated SrcSpan (HsCmdTop GhcRn)
arg2'
; 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
_ LHsExpr GhcPs
op LexicalFixity
f Maybe Fixity
fixity [LHsCmdTop GhcPs]
cmds)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
op',FreeVars
fvOp) <- forall a. TcM a -> TcM a
escapeArrowScope (LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op)
; ([GenLocated SrcSpan (HsCmdTop GhcRn)]
cmds',FreeVars
fvCmds) <- [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [LHsCmdTop GhcPs]
cmds
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' LexicalFixity
f Maybe Fixity
fixity [GenLocated SrcSpan (HsCmdTop GhcRn)]
cmds'
, FreeVars
fvOp FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvCmds) }
rnCmd (HsCmdApp XCmdApp GhcPs
x LHsCmd GhcPs
fun LHsExpr GhcPs
arg)
= do { (GenLocated SrcSpanAnnA (HsCmd GhcRn)
fun',FreeVars
fvFun) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
fun
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg',FreeVars
fvArg) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id
HsCmdApp XCmdApp GhcPs
x GenLocated SrcSpanAnnA (HsCmd GhcRn)
fun' GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg', FreeVars
fvFun FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvArg) }
rnCmd (HsCmdLam XCmdLam GhcPs
_ MatchGroup GhcPs (LHsCmd GhcPs)
matches)
= do { (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
matches', FreeVars
fvMatch) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup (forall p. HsArrowMatchContext -> HsMatchContext p
ArrowMatchCtxt HsArrowMatchContext
KappaExpr) LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLam NoExtField
noExtField MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
matches', FreeVars
fvMatch) }
rnCmd (HsCmdPar XCmdPar GhcPs
x LHsCmd GhcPs
e)
= do { (GenLocated SrcSpanAnnA (HsCmd GhcRn)
e', FreeVars
fvs_e) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdPar id -> LHsCmd id -> HsCmd id
HsCmdPar XCmdPar GhcPs
x GenLocated SrcSpanAnnA (HsCmd GhcRn)
e', FreeVars
fvs_e) }
rnCmd (HsCmdCase XCmdCase GhcPs
_ LHsExpr GhcPs
expr MatchGroup GhcPs (LHsCmd GhcPs)
matches)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
new_expr, FreeVars
e_fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
new_matches, FreeVars
ms_fvs) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup (forall p. HsArrowMatchContext -> HsMatchContext p
ArrowMatchCtxt HsArrowMatchContext
ArrowCaseAlt) LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdCase NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcRn)
new_expr MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
new_matches
, FreeVars
e_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
ms_fvs) }
rnCmd (HsCmdLamCase XCmdLamCase GhcPs
x MatchGroup GhcPs (LHsCmd GhcPs)
matches)
= do { (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
new_matches, FreeVars
ms_fvs) <- forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContext GhcRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup (forall p. HsArrowMatchContext -> HsMatchContext p
ArrowMatchCtxt HsArrowMatchContext
ArrowCaseAlt) LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
matches
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id
HsCmdLamCase XCmdLamCase GhcPs
x MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
new_matches, FreeVars
ms_fvs) }
rnCmd (HsCmdIf XCmdIf GhcPs
_ SyntaxExpr GhcPs
_ LHsExpr GhcPs
p LHsCmd GhcPs
b1 LHsCmd GhcPs
b2)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
p', FreeVars
fvP) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
p
; (GenLocated SrcSpanAnnA (HsCmd GhcRn)
b1', FreeVars
fvB1) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
b1
; (GenLocated SrcSpanAnnA (HsCmd GhcRn)
b2', FreeVars
fvB2) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
b2
; Maybe Name
mb_ite <- RnM (Maybe Name)
lookupIfThenElse
; let (SyntaxExprRn
ite, FreeVars
fvITE) = case Maybe Name
mb_ite of
Just Name
ite_name -> (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
ite_name, Name -> FreeVars
unitFV Name
ite_name)
Maybe Name
Nothing -> (SyntaxExprRn
NoSyntaxExprRn, FreeVars
emptyFVs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
XCmdIf id
-> SyntaxExpr id
-> LHsExpr id
-> LHsCmd id
-> LHsCmd id
-> HsCmd id
HsCmdIf NoExtField
noExtField SyntaxExprRn
ite GenLocated SrcSpanAnnA (HsExpr GhcRn)
p' GenLocated SrcSpanAnnA (HsCmd GhcRn)
b1' GenLocated SrcSpanAnnA (HsCmd GhcRn)
b2', [FreeVars] -> FreeVars
plusFVs [FreeVars
fvITE, FreeVars
fvP, FreeVars
fvB1, FreeVars
fvB2])}
rnCmd (HsCmdLet XCmdLet GhcPs
_ HsLocalBinds GhcPs
binds LHsCmd GhcPs
cmd)
= forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcRn
binds' FreeVars
_ -> do
{ (GenLocated SrcSpanAnnA (HsCmd GhcRn)
cmd',FreeVars
fvExpr) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
cmd
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. XCmdLet id -> HsLocalBinds id -> LHsCmd id -> HsCmd id
HsCmdLet NoExtField
noExtField HsLocalBinds GhcRn
binds' GenLocated SrcSpanAnnA (HsCmd GhcRn)
cmd', FreeVars
fvExpr) }
rnCmd (HsCmdDo XCmdDo GhcPs
_ (L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
stmts))
= do { (([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts', ()
_), FreeVars
fvs) <-
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts forall p. HsStmtContext p
ArrowExpr HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
stmts (\ [Name]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
; forall (m :: * -> *) a. Monad m => a -> m a
return ( forall id. XCmdDo id -> XRec id [CmdLStmt id] -> HsCmd id
HsCmdDo NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts'), FreeVars
fvs ) }
type CmdNeeds = FreeVars
methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
methodNamesLCmd :: LHsCmd GhcRn -> FreeVars
methodNamesLCmd = HsCmd GhcRn -> FreeVars
methodNamesCmd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
methodNamesCmd :: HsCmd GhcRn -> FreeVars
methodNamesCmd (HsCmdArrApp XCmdArrApp GhcRn
_ XRec GhcRn (HsExpr GhcRn)
_arrow XRec GhcRn (HsExpr GhcRn)
_arg HsArrAppType
HsFirstOrderApp Bool
_rtl)
= FreeVars
emptyFVs
methodNamesCmd (HsCmdArrApp XCmdArrApp GhcRn
_ XRec GhcRn (HsExpr GhcRn)
_arrow XRec GhcRn (HsExpr GhcRn)
_arg HsArrAppType
HsHigherOrderApp Bool
_rtl)
= Name -> FreeVars
unitFV Name
appAName
methodNamesCmd (HsCmdArrForm {}) = FreeVars
emptyFVs
methodNamesCmd (HsCmdPar XCmdPar GhcRn
_ LHsCmd GhcRn
c) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c
methodNamesCmd (HsCmdIf XCmdIf GhcRn
_ SyntaxExpr GhcRn
_ XRec GhcRn (HsExpr 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
_ HsLocalBinds GhcRn
_ LHsCmd GhcRn
c) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
c
methodNamesCmd (HsCmdDo XCmdDo GhcRn
_ (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts)) = [CmdLStmt GhcRn] -> FreeVars
methodNamesStmts [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts
methodNamesCmd (HsCmdApp XCmdApp GhcRn
_ LHsCmd GhcRn
c XRec GhcRn (HsExpr 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
_ XRec GhcRn (HsExpr GhcRn)
_ MatchGroup GhcRn (LHsCmd GhcRn)
matches)
= MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch MatchGroup GhcRn (LHsCmd GhcRn)
matches FreeVars -> Name -> FreeVars
`addOneFV` Name
choiceAName
methodNamesCmd (HsCmdLamCase XCmdLamCase GhcRn
_ MatchGroup GhcRn (LHsCmd GhcRn)
matches)
= MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch MatchGroup GhcRn (LHsCmd GhcRn)
matches FreeVars -> Name -> FreeVars
`addOneFV` Name
choiceAName
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
ms })
= [FreeVars] -> FreeVars
plusFVs (forall a b. (a -> b) -> [a] -> [b]
map forall {l}.
GenLocated l (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
do_one [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
ms)
where
do_one :: GenLocated l (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
do_one (L l
_ (Match { m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
grhss })) = GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs GRHSs GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
grhss
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs (GRHSs XCGRHSs GhcRn (LHsCmd GhcRn)
_ [LGRHS GhcRn (LHsCmd GhcRn)]
grhss HsLocalBinds GhcRn
_) = [FreeVars] -> FreeVars
plusFVs (forall a b. (a -> b) -> [a] -> [b]
map Located (GRHS GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesGRHS [LGRHS GhcRn (LHsCmd GhcRn)]
grhss)
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesGRHS (L SrcSpan
_ (GRHS XCGRHS GhcRn (LHsCmd GhcRn)
_ [ExprLStmt GhcRn]
_ LHsCmd GhcRn
rhs)) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
rhs
methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars
methodNamesStmts :: [CmdLStmt GhcRn] -> FreeVars
methodNamesStmts [CmdLStmt GhcRn]
stmts = [FreeVars] -> FreeVars
plusFVs (forall a b. (a -> b) -> [a] -> [b]
map CmdLStmt GhcRn -> FreeVars
methodNamesLStmt [CmdLStmt GhcRn]
stmts)
methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesLStmt :: CmdLStmt GhcRn -> FreeVars
methodNamesLStmt = StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
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 Maybe 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) = LHsCmd GhcRn -> FreeVars
methodNamesLCmd LHsCmd GhcRn
cmd
methodNamesStmt (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts }) =
[CmdLStmt GhcRn] -> FreeVars
methodNamesStmts [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts FreeVars -> Name -> FreeVars
`addOneFV` Name
loopAName
methodNamesStmt (LetStmt {}) = FreeVars
emptyFVs
methodNamesStmt (ParStmt {}) = FreeVars
emptyFVs
methodNamesStmt (TransStmt {}) = FreeVars
emptyFVs
methodNamesStmt ApplicativeStmt{} = FreeVars
emptyFVs
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq (From LHsExpr GhcPs
expr)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> ArithSeqInfo id
From GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr', FreeVars
fvExpr) }
rnArithSeq (FromThen LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr2
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2', FreeVars
fvExpr1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr2) }
rnArithSeq (FromTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr2
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2', FreeVars
fvExpr1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr2) }
rnArithSeq (FromThenTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2 LHsExpr GhcPs
expr3)
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1', FreeVars
fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2', FreeVars
fvExpr2) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr2
; (GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr3', FreeVars
fvExpr3) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr3
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr1' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr2' GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr3',
[FreeVars] -> FreeVars
plusFVs [FreeVars
fvExpr1, FreeVars
fvExpr2, FreeVars
fvExpr3]) }
type AnnoBody body
= ( Outputable (body GhcPs)
, Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
)
rnStmts :: AnnoBody body
=> HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts :: forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody = forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> (HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody forall (body :: * -> *).
HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts
rnStmtsWithPostProcessing
:: AnnoBody body
=> HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> (HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing :: forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> (HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
ppStmts [LStmt GhcPs (LocatedA (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts', thing
thing), FreeVars
fvs) <-
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmtsWithFreeVars HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
; ([GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))]
pp_stmts, FreeVars
fvs') <- HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
ppStmts HsStmtContext GhcRn
ctxt [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts'
; forall (m :: * -> *) a. Monad m => a -> m a
return (([GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))]
pp_stmts, thing
thing), FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs')
}
postProcessStmtsForApplicativeDo
:: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo :: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo HsStmtContext GhcRn
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts
= do {
Bool
ado_is_on <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ApplicativeDo
; let is_do_expr :: Bool
is_do_expr | DoExpr{} <- HsStmtContext GhcRn
ctxt = Bool
True
| Bool
otherwise = Bool
False
; Bool
in_th_bracket <- ThStage -> Bool
isBrackStage 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 -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"ppsfa" (forall a. Outputable a => a -> SDoc
ppr [(ExprLStmt GhcRn, FreeVars)]
stmts)
; HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo HsStmtContext GhcRn
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts }
else forall (body :: * -> *).
HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts HsStmtContext GhcRn
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts }
noPostProcessStmts
:: HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts :: forall (body :: * -> *).
HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts HsStmtContext GhcRn
_ [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
stmts = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
stmts, FreeVars
emptyNameSet)
rnStmtsWithFreeVars :: AnnoBody body
=> HsStmtContext GhcRn
-> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmtsWithFreeVars :: forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmtsWithFreeVars HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
_ [] [Name] -> RnM (thing, FreeVars)
thing_inside
= do { HsStmtContext GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContext GhcRn
ctxt
; (thing
thing, FreeVars
fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
; forall (m :: * -> *) a. Monad m => a -> m a
return (([], thing
thing), FreeVars
fvs) }
rnStmtsWithFreeVars mDoExpr :: HsStmtContext GhcRn
mDoExpr@MDoExpr{} body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
=
do { (([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts1, ([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts2, thing
thing)), FreeVars
fvs)
<- forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmt HsStmtContext GhcRn
mDoExpr body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall (idL :: Pass) bodyR.
(Anno
[GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
~ SrcSpanAnnL) =>
EpAnn AnnList
-> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an a
noLocA [LocatedAn
AnnListItem (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
all_but_last)) forall a b. (a -> b) -> a -> b
$ \ [Name]
_ ->
do { GenLocated
(Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
last_stmt' <- forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContext GhcRn
mDoExpr LocatedAn AnnListItem (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
last_stmt
; forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmt HsStmtContext GhcRn
mDoExpr body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody GenLocated
(Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
last_stmt' [Name] -> RnM (thing, FreeVars)
thing_inside }
; forall (m :: * -> *) a. Monad m => a -> m a
return ((([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts1 forall a. [a] -> [a] -> [a]
++ [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts2), thing
thing), FreeVars
fvs) }
where
Just ([LocatedAn
AnnListItem (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
all_but_last, LocatedAn AnnListItem (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
last_stmt) = forall a. [a] -> Maybe ([a], a)
snocView [LStmt GhcPs (LocatedA (body GhcPs))]
stmts
rnStmtsWithFreeVars HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (lstmt :: LStmt GhcPs (LocatedA (body GhcPs))
lstmt@(L SrcSpanAnnA
loc StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
_) : [LStmt GhcPs (LocatedA (body GhcPs))]
lstmts) [Name] -> RnM (thing, FreeVars)
thing_inside
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LStmt GhcPs (LocatedA (body GhcPs))]
lstmts
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { GenLocated
(Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt' <- forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContext GhcRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt
; forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody GenLocated
(Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt' [Name] -> RnM (thing, FreeVars)
thing_inside }
| Bool
otherwise
= do { (([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts1, ([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts2, thing
thing)), FreeVars
fvs)
<- forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { forall (body :: * -> *).
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext GhcRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt
; forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody LStmt GhcPs (LocatedA (body GhcPs))
lstmt forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs1 ->
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmtsWithFreeVars HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
lstmts forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs2 ->
[Name] -> RnM (thing, FreeVars)
thing_inside ([Name]
bndrs1 forall a. [a] -> [a] -> [a]
++ [Name]
bndrs2) }
; forall (m :: * -> *) a. Monad m => a -> m a
return ((([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts1 forall a. [a] -> [a] -> [a]
++ [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts2), thing
thing), FreeVars
fvs) }
rnStmt :: AnnoBody body
=> HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmt :: forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing),
FreeVars)
rnStmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (L SrcSpanAnnA
loc (LastStmt XLastStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (L SrcSpanAnnA
lb body GhcPs
body) Maybe Bool
noret SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (body GhcRn
body', FreeVars
fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
ret_op, FreeVars
fvs1) <- if forall id. HsStmtContext id -> Bool
isMonadCompContext HsStmtContext GhcRn
ctxt
then HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
returnMName
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)
; (thing
thing, FreeVars
fvs3) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
; forall (m :: * -> *) a. Monad m => a -> m a
return (([(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body') Maybe Bool
noret SyntaxExprRn
ret_op), FreeVars
fv_expr)]
, thing
thing), FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }
rnStmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (L SrcSpanAnnA
loc (BodyStmt XBodyStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (L SrcSpanAnnA
lb body GhcPs
body) SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (body GhcRn
body', FreeVars
fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
then_op, FreeVars
fvs1) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
thenMName
; (SyntaxExprRn
guard_op, FreeVars
fvs2) <- if forall id. HsStmtContext id -> Bool
isComprehensionContext HsStmtContext GhcRn
ctxt
then HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
guardMName
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr, FreeVars
emptyFVs)
; (thing
thing, FreeVars
fvs3) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body') SyntaxExprRn
then_op SyntaxExprRn
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 GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (L SrcSpanAnnA
loc (BindStmt XBindStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ LPat GhcPs
pat (L SrcSpanAnnA
lb body GhcPs
body))) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (body GhcRn
body', FreeVars
fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
bind_op, FreeVars
fvs1) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
bindMName
; (Maybe SyntaxExprRn
fail_op, FreeVars
fvs2) <- LPat GhcPs
-> HsStmtContext GhcRn -> RnM (FailOperator GhcRn, FreeVars)
monadFailOp LPat GhcPs
pat HsStmtContext GhcRn
ctxt
; forall a.
HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat (forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctxt) LPat GhcPs
pat forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
pat' -> do
{ (thing
thing, FreeVars
fvs3) <- [Name] -> RnM (thing, FreeVars)
thing_inside (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat')
; let xbsrn :: XBindStmtRn
xbsrn = XBindStmtRn { xbsrn_bindOp :: SyntaxExpr GhcRn
xbsrn_bindOp = SyntaxExprRn
bind_op, xbsrn_failOp :: FailOperator GhcRn
xbsrn_failOp = Maybe SyntaxExprRn
fail_op }
; forall (m :: * -> *) a. Monad m => a -> m a
return (( [( forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmtRn
xbsrn LPat GhcRn
pat' (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body')), 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 GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ (L SrcSpanAnnA
loc (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ HsLocalBinds GhcPs
binds)) [Name] -> RnM (thing, FreeVars)
thing_inside
= forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
bind_fvs -> do
{ (thing
thing, FreeVars
fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside (forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcRn
binds')
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ([(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn HsLocalBinds GhcRn
binds'), FreeVars
bind_fvs)], thing
thing)
, FreeVars
fvs) }
rnStmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (L SrcSpanAnnA
loc (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
rec_stmts })) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (SyntaxExprRn
return_op, FreeVars
fvs1) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
returnMName
; (SyntaxExprRn
mfix_op, FreeVars
fvs2) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
mfixName
; (SyntaxExprRn
bind_op, FreeVars
fvs3) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
bindMName
; let empty_rec_stmt :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
empty_rec_stmt = forall bodyR.
(Anno
[GenLocated
(Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)]
~ SrcSpanAnnL) =>
StmtLR GhcRn GhcRn bodyR
emptyRecStmtName { recS_ret_fn :: SyntaxExpr GhcRn
recS_ret_fn = SyntaxExprRn
return_op
, recS_mfix_fn :: SyntaxExpr GhcRn
recS_mfix_fn = SyntaxExprRn
mfix_op
, recS_bind_fn :: SyntaxExpr GhcRn
recS_bind_fn = SyntaxExprRn
bind_op }
; forall (body :: * -> *) a.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
rec_stmts forall a b. (a -> b) -> a -> b
$ \ [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs -> do
{ let bndrs :: [Name]
bndrs = FreeVars -> [Name]
nameSetElemsStable forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
unionNameSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(FreeVars
ds,FreeVars
_,FreeVars
_,GenLocated SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))
_) -> FreeVars
ds))
FreeVars
emptyNameSet
[Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs
; (thing
thing, FreeVars
fvs_later) <- [Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs
; let ([LStmt GhcRn (LocatedA (body GhcRn))]
rec_stmts', FreeVars
fvs) = forall (body :: * -> *).
AnnoBody body =>
SrcSpan
-> HsStmtContext GhcRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsStmtContext GhcRn
ctxt StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
empty_rec_stmt [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs FreeVars
fvs_later
; forall (m :: * -> *) a. Monad m => a -> m a
return ( ((forall a b. [a] -> [b] -> [(a, b)]
zip [LStmt GhcRn (LocatedA (body GhcRn))]
rec_stmts' (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 GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
_ (L SrcSpanAnnA
loc (ParStmt XParStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ [ParStmtBlock GhcPs GhcPs]
segs HsExpr GhcPs
_ SyntaxExpr GhcPs
_)) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (HsExpr GhcRn
mzip_op, FreeVars
fvs1) <- HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext GhcRn
ctxt Name
mzipName
; (SyntaxExprRn
bind_op, FreeVars
fvs2) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
bindMName
; (SyntaxExprRn
return_op, FreeVars
fvs3) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
returnMName
; (([ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs4) <- forall thing.
HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts (forall p. HsStmtContext p -> HsStmtContext p
ParStmtCtxt HsStmtContext GhcRn
ctxt) SyntaxExprRn
return_op [ParStmtBlock GhcPs GhcPs]
segs [Name] -> RnM (thing, FreeVars)
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (([(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt NoExtField
noExtField [ParStmtBlock GhcRn GhcRn]
segs' HsExpr GhcRn
mzip_op SyntaxExprRn
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 GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
_ (L SrcSpanAnnA
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 {
(GenLocated SrcSpanAnnA (HsExpr GhcRn)
using', FreeVars
fvs1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
using
; (([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts', (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by', [Name]
used_bndrs, thing
thing)), FreeVars
fvs2)
<- forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts (forall p. HsStmtContext p -> HsStmtContext p
TransStmtCtxt HsStmtContext GhcRn
ctxt) HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr [ExprLStmt GhcPs]
stmts forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs ->
do { (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by', FreeVars
fvs_by) <- forall a b.
(a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
; forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by', [Name]
used_bndrs, thing
thing), FreeVars
fvs) }
; (SyntaxExprRn
return_op, FreeVars
fvs3) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
returnMName
; (SyntaxExprRn
bind_op, FreeVars
fvs4) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
bindMName
; (HsExpr GhcRn
fmap_op, FreeVars
fvs5) <- case TransForm
form of
TransForm
ThenForm -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: Pass). HsExpr (GhcPass p)
noExpr, FreeVars
emptyFVs)
TransForm
_ -> HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext GhcRn
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 forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
used_bndrs
; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rnStmt: implicitly rebound these used binders:" (forall a. Outputable a => a -> SDoc
ppr [(Name, Name)]
bndr_map)
; forall (m :: * -> *) a. Monad m => a -> m a
return (([(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (TransStmt { trS_ext :: XTransStmt GhcRn GhcRn (LocatedA (body GhcRn))
trS_ext = NoExtField
noExtField
, trS_stmts :: [ExprLStmt GhcRn]
trS_stmts = [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts', trS_bndrs :: [(IdP GhcRn, IdP GhcRn)]
trS_bndrs = [(Name, Name)]
bndr_map
, trS_by :: Maybe (XRec GhcRn (HsExpr GhcRn))
trS_by = Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn))
by', trS_using :: XRec GhcRn (HsExpr GhcRn)
trS_using = GenLocated SrcSpanAnnA (HsExpr GhcRn)
using', trS_form :: TransForm
trS_form = TransForm
form
, trS_ret :: SyntaxExpr GhcRn
trS_ret = SyntaxExprRn
return_op, trS_bind :: SyntaxExpr GhcRn
trS_bind = SyntaxExprRn
bind_op
, trS_fmap :: HsExpr GhcRn
trS_fmap = HsExpr GhcRn
fmap_op }), FreeVars
fvs2)], thing
thing), FreeVars
all_fvs) }
rnStmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ (L SrcSpanAnnA
_ ApplicativeStmt{}) [Name] -> RnM (thing, FreeVars)
_ =
forall a. String -> a
panic String
"rnStmt: ApplicativeStmt"
rnParallelStmts :: forall thing. HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts :: forall thing.
HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts HsStmtContext GhcRn
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) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Name -> Name -> Ordering
cmpByOcc [Name]
bndrs_so_far
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}.
Outputable a =>
NonEmpty a -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr [NonEmpty Name]
dups
; (thing
thing, FreeVars
fvs) <- forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs' ([Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs')
; 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 { (([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts', ([Name]
used_bndrs, [ParStmtBlock GhcRn GhcRn]
segs', thing
thing)), FreeVars
fvs)
<- forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContext GhcRn
ctxt HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnExpr [ExprLStmt GhcPs]
stmts forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs ->
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
env 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 forall a. [a] -> [a] -> [a]
++ [Name]
bndrs_so_far) [ParStmtBlock GhcPs GhcPs]
segs
; let used_bndrs :: [Name]
used_bndrs = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
; 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' = forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcPs GhcPs
x [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts' [Name]
used_bndrs SyntaxExpr GhcRn
return_op
; forall (m :: * -> *) a. Monad m => a -> m a
return ((ParStmtBlock GhcRn GhcRn
seg'forall a. a -> [a] -> [a]
:[ParStmtBlock GhcRn GhcRn]
segs', thing
thing), FreeVars
fvs) }
cmpByOcc :: Name -> Name -> Ordering
cmpByOcc Name
n1 Name
n2 = Name -> OccName
nameOccName Name
n1 forall a. Ord a => a -> a -> Ordering
`compare` Name -> OccName
nameOccName Name
n2
dupErr :: NonEmpty a -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr NonEmpty a
vs = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (String -> SDoc
text String
"Duplicate binding in parallel list comprehension for:"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall a. NonEmpty a -> a
NE.head NonEmpty a
vs)))
lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
n
= case forall p. HsStmtContext p -> Maybe ModuleName
qualifiedDoModuleName_maybe HsStmtContext GhcRn
ctxt of
Maybe ModuleName
Nothing -> HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
n
Just ModuleName
modName ->
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (HsExpr GhcRn -> SyntaxExprRn
mkSyntaxExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> HsExpr (GhcPass p)
nl_HsVar) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ModuleName -> RnM (Name, FreeVars)
lookupNameWithQualifier Name
n ModuleName
modName
lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContext GhcRn
ctxt Name
n
| HsStmtContext GhcRn -> Bool
rebindableContext HsStmtContext GhcRn
ctxt
= Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
n
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
n, FreeVars
emptyFVs)
lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContext GhcRn
ctxt Name
name
| HsStmtContext GhcRn -> Bool
rebindableContext HsStmtContext GhcRn
ctxt
= do { Bool
rebindable_on <- 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)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA Name
name), FreeVars
emptyFVs)
rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext HsStmtContext GhcRn
ctxt = case HsStmtContext GhcRn
ctxt of
HsStmtContext GhcRn
ListComp -> Bool
False
HsStmtContext GhcRn
ArrowExpr -> Bool
False
PatGuard {} -> Bool
False
DoExpr Maybe ModuleName
m -> forall a. Maybe a -> Bool
isNothing Maybe ModuleName
m
MDoExpr Maybe ModuleName
m -> forall a. Maybe a -> Bool
isNothing Maybe ModuleName
m
HsStmtContext GhcRn
MonadComp -> Bool
True
HsStmtContext GhcRn
GhciStmtCtxt -> Bool
True
ParStmtCtxt HsStmtContext GhcRn
c -> HsStmtContext GhcRn -> Bool
rebindableContext HsStmtContext GhcRn
c
TransStmtCtxt HsStmtContext GhcRn
c -> HsStmtContext GhcRn -> Bool
rebindableContext HsStmtContext GhcRn
c
type FwdRefs = NameSet
type Segment stmts = (Defs,
Uses,
FwdRefs,
stmts)
rnRecStmtsAndThen :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen :: forall (body :: * -> *) a.
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
s [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars)
cont
= do {
MiniFixityEnv
fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv (forall body. [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmt GhcPs (LocatedA (body GhcPs))]
s)
; [(GenLocated
(Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv <- forall (body :: * -> *).
AnnoBody body =>
MiniFixityEnv
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [LStmt GhcPs (LocatedA (body GhcPs))]
s
; let bound_names :: [IdP GhcRn]
bound_names = forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders forall p. CollectFlag p
CollNoDictBinders (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated
(Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv)
rec_uses :: [(SrcSpan, [Name])]
rec_uses = forall (idR :: Pass) (body :: * -> *).
[LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
-> [(SrcSpan, [Name])]
lStmtsImplicits (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated
(Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv)
implicit_uses :: FreeVars
implicit_uses = [Name] -> FreeVars
mkNameSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [(SrcSpan, [Name])]
rec_uses
; forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [IdP GhcRn]
bound_names forall a b. (a -> b) -> a -> b
$
forall a. MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities MiniFixityEnv
fix_env [IdP GhcRn]
bound_names forall a b. (a -> b) -> a -> b
$ do
{ [Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
segs <- forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmts HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [IdP GhcRn]
bound_names [(GenLocated
(Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
(StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv
; (a
res, FreeVars
fvs) <- [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars)
cont [Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
segs
; 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 (forall a. a -> Maybe a
Just [Name]
ns))
[(SrcSpan, [Name])]
rec_uses
; [Name] -> FreeVars -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnUnusedLocalBinds [IdP GhcRn]
bound_names (FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
implicit_uses)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, FreeVars
fvs) }}
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities :: forall body. [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmtLR GhcPs GhcPs body]
l =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)
s -> \[GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc -> case GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)
s of
(L Anno (StmtLR GhcPs GhcPs body)
_ (LetStmt XLetStmt GhcPs GhcPs body
_ (HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
_ [LSig GhcPs]
sigs)))) ->
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ GenLocated SrcSpanAnnA (Sig GhcPs)
sig -> \ [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc -> case GenLocated SrcSpanAnnA (Sig GhcPs)
sig of
(L SrcSpanAnnA
loc (FixSig XFixSig GhcPs
_ FixitySig GhcPs
s)) -> (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FixitySig GhcPs
s) forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc
GenLocated SrcSpanAnnA (Sig GhcPs)
_ -> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc) [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc [LSig GhcPs]
sigs
GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)
_ -> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc) [] [LStmtLR GhcPs GhcPs body]
l
rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmt_lhs :: forall (body :: * -> *).
AnnoBody body =>
MiniFixityEnv
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
loc (BodyStmt XBodyStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ LocatedA (body GhcPs)
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b))
= forall (m :: * -> *) a. Monad m => a -> m a
return [(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
noExtField LocatedA (body GhcPs)
body SyntaxExpr GhcPs
a SyntaxExpr GhcPs
b), FreeVars
emptyFVs)]
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
loc (LastStmt XLastStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ LocatedA (body GhcPs)
body Maybe Bool
noret SyntaxExpr GhcPs
a))
= forall (m :: * -> *) a. Monad m => a -> m a
return [(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt NoExtField
noExtField LocatedA (body GhcPs)
body Maybe Bool
noret SyntaxExpr GhcPs
a), FreeVars
emptyFVs)]
rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpanAnnA
loc (BindStmt XBindStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ LPat GhcPs
pat LocatedA (body GhcPs)
body))
= do
(GenLocated SrcSpanAnnA (Pat GhcRn)
pat', FreeVars
fv_pat) <- NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, FreeVars)
rnBindPat (MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env) LPat GhcPs
pat
forall (m :: * -> *) a. Monad m => a -> m a
return [(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcRn)
pat' LocatedA (body GhcPs)
body), FreeVars
fv_pat)]
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ binds :: HsLocalBinds GhcPs
binds@(HsIPBinds {})))
= forall a. SDoc -> TcRn a
failWith (forall a. Outputable a => SDoc -> a -> SDoc
badIpBinds (String -> SDoc
text String
"an mdo expression") HsLocalBinds GhcPs
binds)
rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpanAnnA
loc (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (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
forall (m :: * -> *) a. Monad m => a -> m a
return [(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
x HsValBindsLR GhcRn GhcPs
binds')),
FreeVars
emptyFVs
)]
rn_rec_stmt_lhs MiniFixityEnv
fix_env (L SrcSpanAnnA
_ (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
stmts }))
= forall (body :: * -> *).
AnnoBody body =>
MiniFixityEnv
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
stmts
rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs (LocatedA (body GhcPs))
stmt@(L SrcSpanAnnA
_ (ParStmt {}))
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt" (forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
stmt)
rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs (LocatedA (body GhcPs))
stmt@(L SrcSpanAnnA
_ (TransStmt {}))
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt" (forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
stmt)
rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs (LocatedA (body GhcPs))
stmt@(L SrcSpanAnnA
_ (ApplicativeStmt {}))
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt" (forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
stmt)
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)))
= forall a. String -> a
panic String
"rn_rec_stmt LetStmt EmptyLocalBinds"
rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmts_lhs :: forall (body :: * -> *).
AnnoBody body =>
MiniFixityEnv
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmts_lhs MiniFixityEnv
fix_env [LStmt GhcPs (LocatedA (body GhcPs))]
stmts
= do { [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
ls <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall (body :: * -> *).
AnnoBody body =>
MiniFixityEnv
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
rn_rec_stmt_lhs MiniFixityEnv
fix_env) [LStmt GhcPs (LocatedA (body GhcPs))]
stmts
; let boundNames :: [IdP GhcRn]
boundNames = forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders forall p. CollectFlag p
CollNoDictBinders (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
ls)
; [Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkDupNames [IdP GhcRn]
boundNames
; forall (m :: * -> *) a. Monad m => a -> m a
return [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
ls }
rn_rec_stmt :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt :: forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
_ (L SrcSpanAnnA
loc (LastStmt XLastStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ (L SrcSpanAnnA
lb body GhcPs
body) Maybe Bool
noret SyntaxExpr GhcPs
_), FreeVars
_)
= do { (body GhcRn
body', FreeVars
fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
ret_op, FreeVars
fvs1) <- forall p.
HsStmtContext p -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo HsStmtContext GhcRn
ctxt Name
returnMName
; forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
emptyNameSet, FreeVars
fv_expr FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1, FreeVars
emptyNameSet,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body') Maybe Bool
noret SyntaxExprRn
ret_op))] }
rn_rec_stmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
_ (L SrcSpanAnnA
loc (BodyStmt XBodyStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ (L SrcSpanAnnA
lb body GhcPs
body) SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_), FreeVars
_)
= do { (body GhcRn
body', FreeVars
fvs) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
then_op, FreeVars
fvs1) <- forall p.
HsStmtContext p -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo HsStmtContext GhcRn
ctxt Name
thenMName
; forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
emptyNameSet, FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs1, FreeVars
emptyNameSet,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body') SyntaxExprRn
then_op forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr))] }
rn_rec_stmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
_ (L SrcSpanAnnA
loc (BindStmt XBindStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ LPat GhcRn
pat' (L SrcSpanAnnA
lb body GhcPs
body)), FreeVars
fv_pat)
= do { (body GhcRn
body', FreeVars
fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (SyntaxExprRn
bind_op, FreeVars
fvs1) <- forall p.
HsStmtContext p -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo HsStmtContext GhcRn
ctxt Name
bindMName
; (Maybe SyntaxExprRn
fail_op, FreeVars
fvs2) <- forall p. HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp HsStmtContext GhcRn
ctxt
; let bndrs :: FreeVars
bndrs = [Name] -> FreeVars
mkNameSet (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders 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
; let xbsrn :: XBindStmtRn
xbsrn = XBindStmtRn { xbsrn_bindOp :: SyntaxExpr GhcRn
xbsrn_bindOp = SyntaxExprRn
bind_op, xbsrn_failOp :: FailOperator GhcRn
xbsrn_failOp = Maybe SyntaxExprRn
fail_op }
; forall (m :: * -> *) a. Monad m => a -> m a
return [(FreeVars
bndrs, FreeVars
fvs, FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmtRn
xbsrn LPat GhcRn
pat' (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lb body GhcRn
body')))] }
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ binds :: HsLocalBindsLR GhcRn GhcPs
binds@(HsIPBinds {})), FreeVars
_)
= forall a. SDoc -> TcRn a
failWith (forall a. Outputable a => SDoc -> a -> SDoc
badIpBinds (String -> SDoc
text String
"an mdo expression") HsLocalBindsLR GhcRn GhcPs
binds)
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
all_bndrs (L SrcSpanAnnA
loc (LetStmt XLetStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ (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'
; let fvs :: FreeVars
fvs = DefUses -> FreeVars
allUses DefUses
du_binds
; forall (m :: * -> *) a. Monad m => a -> m a
return [(DefUses -> FreeVars
duDefs DefUses
du_binds, FreeVars
fvs, FreeVars
emptyNameSet,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcPs
x HsValBinds GhcRn
binds')))] }
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (RecStmt {}), FreeVars
_)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: RecStmt" (forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt)
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (ParStmt {}), FreeVars
_)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: ParStmt" (forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt)
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (TransStmt {}), FreeVars
_)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: TransStmt" (forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt)
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcPs
_)), FreeVars
_)
= forall a. String -> a
panic String
"rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt HsStmtContext GhcRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (ApplicativeStmt {}), FreeVars
_)
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: ApplicativeStmt" (forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt)
rn_rec_stmts :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmts :: forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmts HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
bndrs [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
stmts
= do { [[Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]]
segs_s <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt HsStmtContext GhcRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
bndrs) [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
stmts
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]]
segs_s) }
segmentRecStmts :: AnnoBody body
=> SrcSpan -> HsStmtContext GhcRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts :: forall (body :: * -> *).
AnnoBody body =>
SrcSpan
-> HsStmtContext GhcRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts SrcSpan
loc HsStmtContext GhcRn
ctxt Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs FreeVars
fvs_later
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs
= ([], FreeVars
fvs_later)
| MDoExpr Maybe ModuleName
_ <- HsStmtContext GhcRn
ctxt
= forall (body :: * -> *).
Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
grouped_segs FreeVars
fvs_later
| Bool
otherwise
= ([ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) forall a b. (a -> b) -> a -> b
$
Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt { recS_stmts :: XRec GhcRn [LStmt GhcRn (LocatedA (body GhcRn))]
recS_stmts = forall a an. a -> LocatedAn an a
noLocA [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
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) }]
, FreeVars
uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_later)
where
([FreeVars]
defs_s, [FreeVars]
uses_s, [FreeVars]
_, [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
ss) = forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs
defs :: FreeVars
defs = [FreeVars] -> FreeVars
plusFVs [FreeVars]
defs_s
uses :: FreeVars
uses = [FreeVars] -> FreeVars
plusFVs [FreeVars]
uses_s
segs_w_fwd_refs :: [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
segs_w_fwd_refs = forall a. [Segment a] -> [Segment a]
addFwdRefs [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs
grouped_segs :: [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
grouped_segs = forall body.
HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext GhcRn
ctxt [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
segs_w_fwd_refs
addFwdRefs :: [Segment a] -> [Segment a]
addFwdRefs :: forall a. [Segment a] -> [Segment a]
addFwdRefs [Segment a]
segs
= forall a b. (a, b) -> a
fst (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 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)
glomSegments :: HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
glomSegments :: forall body.
HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext GhcRn
_ [] = []
glomSegments HsStmtContext GhcRn
ctxt ((FreeVars
defs,FreeVars
uses,FreeVars
fwds,LStmt GhcRn body
stmt) : [Segment (LStmt GhcRn body)]
segs)
= (FreeVars
seg_defs, FreeVars
seg_uses, FreeVars
seg_fwds, [GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
seg_stmts) forall a. a -> [a] -> [a]
: [(FreeVars, FreeVars, FreeVars,
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)])]
others
where
segs' :: [Segment [LStmt GhcRn body]]
segs' = forall body.
HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContext GhcRn
ctxt [Segment (LStmt GhcRn body)]
segs
([(FreeVars, FreeVars, FreeVars,
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)])]
extras, [(FreeVars, FreeVars, FreeVars,
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)])]
others) = forall a. FreeVars -> [Segment a] -> ([Segment a], [Segment a])
grab FreeVars
uses [Segment [LStmt GhcRn body]]
segs'
([FreeVars]
ds, [FreeVars]
us, [FreeVars]
fs, [[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
ss) = forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(FreeVars, FreeVars, FreeVars,
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn 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 :: [GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
seg_stmts = LStmt GhcRn body
stmt forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
ss
grab :: NameSet
-> [Segment a]
-> ([Segment a],
[Segment a])
grab :: forall a. FreeVars -> [Segment a] -> ([Segment a], [Segment a])
grab FreeVars
uses [Segment a]
dus
= (forall a. [a] -> [a]
reverse [Segment a]
yeses, forall a. [a] -> [a]
reverse [Segment a]
noes)
where
([Segment a]
noes, [Segment a]
yeses) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Segment a -> Bool
not_needed (forall a. [a] -> [a]
reverse [Segment a]
dus)
not_needed :: Segment a -> Bool
not_needed (FreeVars
defs,FreeVars
_,FreeVars
_,a
_) = FreeVars -> FreeVars -> Bool
disjointNameSet FreeVars
defs FreeVars
uses
segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts :: forall (body :: * -> *).
Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts Stmt GhcRn (LocatedA (body GhcRn))
_ [] FreeVars
fvs_later = ([], FreeVars
fvs_later)
segsToStmts Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt ((FreeVars
defs, FreeVars
uses, FreeVars
fwds, [LStmt GhcRn (LocatedA (body GhcRn))]
ss) : [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
segs) FreeVars
fvs_later
= ASSERT( not (null ss) )
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
new_stmt forall a. a -> [a] -> [a]
: [LStmt GhcRn (LocatedA (body GhcRn))]
later_stmts, FreeVars
later_uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
uses)
where
([LStmt GhcRn (LocatedA (body GhcRn))]
later_stmts, FreeVars
later_uses) = forall (body :: * -> *).
Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
segs FreeVars
fvs_later
new_stmt :: GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
new_stmt | Bool
non_rec = forall a. [a] -> a
head [LStmt GhcRn (LocatedA (body GhcRn))]
ss
| Bool
otherwise = forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc (forall a. [a] -> a
head [LStmt GhcRn (LocatedA (body GhcRn))]
ss)) Stmt GhcRn (LocatedA (body GhcRn))
rec_stmt
rec_stmt :: Stmt GhcRn (LocatedA (body GhcRn))
rec_stmt = Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt { recS_stmts :: XRec GhcRn [LStmt GhcRn (LocatedA (body GhcRn))]
recS_stmts = forall a an. a -> LocatedAn an a
noLocA [LStmt GhcRn (LocatedA (body GhcRn))]
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 }
non_rec :: Bool
non_rec = forall a. [a] -> Bool
isSingleton [LStmt GhcRn (LocatedA (body GhcRn))]
ss Bool -> Bool -> Bool
&& FreeVars -> Bool
isEmptyNameSet FreeVars
fwds
used_later :: FreeVars
used_later = FreeVars
defs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
later_uses
data MonadNames = MonadNames { MonadNames -> Name
return_name, MonadNames -> Name
pure_name :: Name }
instance Outputable MonadNames where
ppr :: MonadNames -> SDoc
ppr (MonadNames {return_name :: MonadNames -> Name
return_name=Name
return_name,pure_name :: MonadNames -> Name
pure_name=Name
pure_name}) =
[SDoc] -> SDoc
hcat
[String -> SDoc
text String
"MonadNames { return_name = "
,forall a. Outputable a => a -> SDoc
ppr Name
return_name
,String -> SDoc
text String
", pure_name = "
,forall a. Outputable a => a -> SDoc
ppr Name
pure_name
,String -> SDoc
text String
"}"
]
rearrangeForApplicativeDo
:: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo :: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo HsStmtContext GhcRn
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsStmtContext GhcRn
_ [(ExprLStmt GhcRn
one,FreeVars
_)] = forall (m :: * -> *) a. Monad m => a -> m a
return ([ExprLStmt GhcRn
one], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsStmtContext GhcRn
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts0 = do
Bool
optimal_ado <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_OptimalApplicativeDo
let stmt_tree :: ExprStmtTree
stmt_tree | Bool
optimal_ado = [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
| Bool
otherwise = [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn String
"rearrangeForADo" (forall a. Outputable a => a -> SDoc
ppr ExprStmtTree
stmt_tree)
(Name
return_name, FreeVars
_) <- forall p. HsStmtContext p -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName HsStmtContext GhcRn
ctxt Name
returnMName
(Name
pure_name, FreeVars
_) <- forall p. HsStmtContext p -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName HsStmtContext GhcRn
ctxt Name
pureAName
let monad_names :: MonadNames
monad_names = MonadNames { return_name :: Name
return_name = Name
return_name
, pure_name :: Name
pure_name = Name
pure_name }
MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt ExprStmtTree
stmt_tree [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
last] FreeVars
last_fvs
where
([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts,(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
last,FreeVars
last_fvs)) = forall {a}. [a] -> ([a], a)
findLast [(ExprLStmt GhcRn, FreeVars)]
stmts0
findLast :: [a] -> ([a], a)
findLast [] = forall a. HasCallStack => String -> a
error String
"findLast"
findLast [a
last] = ([],a
last)
findLast (a
x:[a]
xs) = (a
xforall a. a -> [a] -> [a]
:[a]
rest,a
last) where ([a]
rest,a
last) = [a] -> ([a], a)
findLast [a]
xs
data StmtTree a
= StmtTreeOne a
| StmtTreeBind (StmtTree a) (StmtTree a)
| StmtTreeApplicative [StmtTree a]
instance Outputable a => Outputable (StmtTree a) where
ppr :: StmtTree a -> SDoc
ppr (StmtTreeOne a
x) = SDoc -> SDoc
parens (String -> SDoc
text String
"StmtTreeOne" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
x)
ppr (StmtTreeBind StmtTree a
x StmtTree a
y) = SDoc -> SDoc
parens (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"StmtTreeBind")
Int
2 ([SDoc] -> SDoc
sep [forall a. Outputable a => a -> SDoc
ppr StmtTree a
x, forall a. Outputable a => a -> SDoc
ppr StmtTree a
y]))
ppr (StmtTreeApplicative [StmtTree a]
xs) = SDoc -> SDoc
parens (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"StmtTreeApplicative")
Int
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [StmtTree a]
xs)))
flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree :: forall a. StmtTree a -> [a]
flattenStmtTree StmtTree a
t = forall {a}. StmtTree a -> [a] -> [a]
go StmtTree a
t []
where
go :: StmtTree a -> [a] -> [a]
go (StmtTreeOne a
a) [a]
as = 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 = 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
mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(ExprLStmt GhcRn, FreeVars)
one] = forall a. a -> StmtTree a
StmtTreeOne (ExprLStmt GhcRn, FreeVars)
one
mkStmtTreeHeuristic [(ExprLStmt GhcRn, FreeVars)]
stmts =
case [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
segments [(ExprLStmt GhcRn, FreeVars)]
stmts of
[[(ExprLStmt GhcRn, FreeVars)]
one] -> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
split [(ExprLStmt GhcRn, FreeVars)]
one
[[(ExprLStmt GhcRn, FreeVars)]]
segs -> forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative (forall a b. (a -> b) -> [a] -> [b]
map [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
split [[(ExprLStmt GhcRn, FreeVars)]]
segs)
where
split :: [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
split [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
one] = forall a. a -> StmtTree a
StmtTreeOne (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
one
split [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts =
forall a. StmtTree a -> StmtTree a -> StmtTree a
StmtTreeBind ([(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(ExprLStmt GhcRn, FreeVars)]
before) ([(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(ExprLStmt GhcRn, FreeVars)]
after)
where ([(ExprLStmt GhcRn, FreeVars)]
before, [(ExprLStmt GhcRn, FreeVars)]
after) = [(ExprLStmt GhcRn, FreeVars)]
-> ([(ExprLStmt GhcRn, FreeVars)], [(ExprLStmt GhcRn, FreeVars)])
splitSegment [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal [(ExprLStmt GhcRn, FreeVars)]
stmts =
ASSERT(not (null stmts))
forall a b. (a, b) -> a
fst (Array (Int, Int) (ExprStmtTree, Int)
arr forall i e. Ix i => Array i e -> i -> e
! (Int
0,Int
n))
where
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ExprLStmt GhcRn, FreeVars)]
stmts forall a. Num a => a -> a -> a
- Int
1
stmt_arr :: Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
n) [(ExprLStmt GhcRn, FreeVars)]
stmts
arr :: Array (Int,Int) (ExprStmtTree, Cost)
arr :: Array (Int, Int) (ExprStmtTree, Int)
arr = 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
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
tree Int
lo Int
hi)
| Int
lo <- [Int
0..Int
n]
, Int
hi <- [Int
lo..Int
n] ]
tree :: Int
-> Int
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
tree Int
lo Int
hi
| Int
hi forall a. Eq a => a -> a -> Bool
== Int
lo = (forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1)
| Bool
otherwise =
case [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
segments [ Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- [Int
lo..Int
hi] ] of
[] -> forall a. String -> a
panic String
"mkStmtTree"
[[(ExprLStmt GhcRn, FreeVars)]
_one] -> Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
[[(ExprLStmt GhcRn, FreeVars)]]
segs -> (forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative [StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
trees, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
costs)
where
bounds :: [(Int, Int)]
bounds = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Int
_,Int
hi) [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
a -> (Int
hiforall a. Num a => a -> a -> a
+Int
1, Int
hi forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
a)) (Int
0,Int
loforall a. Num a => a -> a -> a
-Int
1) [[(ExprLStmt GhcRn, FreeVars)]]
segs
([StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
trees,[Int]
costs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> (ExprStmtTree, Int)
split) (forall a. [a] -> [a]
tail [(Int, Int)]
bounds))
split :: Int -> Int -> (ExprStmtTree, Cost)
split :: Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
| Int
hi forall a. Eq a => a -> a -> Bool
== Int
lo = (forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1)
| Bool
otherwise = (forall a. StmtTree a -> StmtTree a -> StmtTree a
StmtTreeBind StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
before StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
after, Int
c1forall a. Num a => a -> a -> a
+Int
c2)
where
((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
before,Int
c1),(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
after,Int
c2))
| Int
hi forall a. Num a => a -> a -> a
- Int
lo forall a. Eq a => a -> a -> Bool
== Int
1
= ((forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1),
(forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
| Int
left_cost forall a. Ord a => a -> a -> Bool
< Int
right_cost
= ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
left,Int
left_cost), (forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
| Int
left_cost forall a. Ord a => a -> a -> Bool
> Int
right_cost
= ((forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1), (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
right,Int
right_cost))
| Bool
otherwise = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall {a} {a} {a}. Num a => ((a, a), (a, a)) -> a
cost) [((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))]
alternatives
where
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
left, Int
left_cost) = Array (Int, Int) (ExprStmtTree, Int)
arr forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
hiforall a. Num a => a -> a -> a
-Int
1)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
right, Int
right_cost) = Array (Int, Int) (ExprStmtTree, Int)
arr forall i e. Ix i => Array i e -> i -> e
! (Int
loforall 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 forall a. Num a => a -> a -> a
+ a
c2
alternatives :: [((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))]
alternatives = [ (Array (Int, Int) (ExprStmtTree, Int)
arr forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
k), Array (Int, Int) (ExprStmtTree, Int)
arr forall i e. Ix i => Array i e -> i -> e
! (Int
kforall a. Num a => a -> a -> a
+Int
1,Int
hi))
| Int
k <- [Int
lo .. Int
hiforall a. Num a => a -> a -> a
-Int
1] ]
stmtTreeToStmts
:: MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ( [ExprLStmt GhcRn]
, FreeVars )
stmtTreeToStmts :: MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt (StmtTreeOne (L SrcSpanAnnA
_ (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbs LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs), FreeVars
_))
[ExprLStmt GhcRn]
tail FreeVars
_tail_fvs
| Bool -> Bool
not (forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat GhcRn
pat), (Bool
False,[ExprLStmt GhcRn]
tail') <- MonadNames -> [ExprLStmt GhcRn] -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
monad_names [ExprLStmt GhcRn]
tail
= HsStmtContext GhcRn
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsStmtContext GhcRn
ctxt [ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbs
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
, is_body_stmt :: Bool
is_body_stmt = Bool
False
}]
Bool
False [ExprLStmt GhcRn]
tail'
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt (StmtTreeOne (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_),FreeVars
_))
[ExprLStmt GhcRn]
tail FreeVars
_tail_fvs
| (Bool
False,[ExprLStmt GhcRn]
tail') <- MonadNames -> [ExprLStmt GhcRn] -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
monad_names [ExprLStmt GhcRn]
tail
= HsStmtContext GhcRn
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsStmtContext GhcRn
ctxt
[ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = forall a. Maybe a
Nothing
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
nlWildPatName
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
, is_body_stmt :: Bool
is_body_stmt = Bool
True
}] Bool
False [ExprLStmt GhcRn]
tail'
stmtTreeToStmts MonadNames
_monad_names HsStmtContext GhcRn
_ctxt (StmtTreeOne (ExprLStmt GhcRn
s,FreeVars
_)) [ExprLStmt GhcRn]
tail FreeVars
_tail_fvs =
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprLStmt GhcRn
s forall a. a -> [a] -> [a]
: [ExprLStmt GhcRn]
tail, FreeVars
emptyNameSet)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt (StmtTreeBind ExprStmtTree
before ExprStmtTree
after) [ExprLStmt GhcRn]
tail FreeVars
tail_fvs = do
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts1, FreeVars
fvs1) <- MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt ExprStmtTree
after [ExprLStmt GhcRn]
tail FreeVars
tail_fvs
let tail1_fvs :: FreeVars
tail1_fvs = [FreeVars] -> FreeVars
unionNameSets (FreeVars
tail_fvs forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall a. StmtTree a -> [a]
flattenStmtTree ExprStmtTree
after))
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts2, FreeVars
fvs2) <- MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt ExprStmtTree
before [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts1 FreeVars
tail1_fvs
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts2, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt (StmtTreeApplicative [ExprStmtTree]
trees) [ExprLStmt GhcRn]
tail FreeVars
tail_fvs = do
[(ApplicativeArg GhcRn, FreeVars)]
pairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsStmtContext GhcRn
-> FreeVars
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
stmtTreeArg HsStmtContext GhcRn
ctxt FreeVars
tail_fvs) [ExprStmtTree]
trees
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let ([ApplicativeArg GhcRn]
stmts', [FreeVars]
fvss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(ApplicativeArg GhcRn, FreeVars)]
pairs
let (Bool
need_join, [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
tail') =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DynFlags -> ApplicativeArg GhcRn -> Bool
hasRefutablePattern DynFlags
dflags) [ApplicativeArg GhcRn]
stmts'
then (Bool
True, [ExprLStmt GhcRn]
tail)
else MonadNames -> [ExprLStmt GhcRn] -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
monad_names [ExprLStmt GhcRn]
tail
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts, FreeVars
fvs) <- HsStmtContext GhcRn
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsStmtContext GhcRn
ctxt [ApplicativeArg GhcRn]
stmts' Bool
need_join [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
tail'
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts, [FreeVars] -> FreeVars
unionNameSets (FreeVars
fvsforall a. a -> [a] -> [a]
:[FreeVars]
fvss))
where
stmtTreeArg :: HsStmtContext GhcRn
-> FreeVars
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
stmtTreeArg HsStmtContext GhcRn
_ctxt FreeVars
_tail_fvs (StmtTreeOne (L SrcSpanAnnA
_ (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbs LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp), FreeVars
_))
= forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XBindStmtRn -> FailOperator GhcRn
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
xbs
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp
, is_body_stmt :: Bool
is_body_stmt = Bool
False
}, FreeVars
emptyFVs)
stmtTreeArg HsStmtContext GhcRn
_ctxt FreeVars
_tail_fvs (StmtTreeOne (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_), FreeVars
_)) =
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = forall a. Maybe a
Nothing
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
nlWildPatName
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp
, is_body_stmt :: Bool
is_body_stmt = Bool
True
}, FreeVars
emptyFVs)
stmtTreeArg HsStmtContext GhcRn
ctxt FreeVars
tail_fvs StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
tree = do
let stmts :: [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts = forall a. StmtTree a -> [a]
flattenStmtTree StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
tree
pvarset :: FreeVars
pvarset = [Name] -> FreeVars
mkNameSet (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders forall p. CollectFlag p
CollNoDictBinders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts)
FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
tail_fvs
pvars :: [Name]
pvars = FreeVars -> [Name]
nameSetElemsStable FreeVars
pvarset
pat :: LPat GhcRn
pat = [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup [Name]
pvars
tup :: XRec GhcRn (HsExpr GhcRn)
tup = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkBigLHsVarTup [Name]
pvars NoExtField
noExtField
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts',FreeVars
fvs2) <- MonadNames
-> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsStmtContext GhcRn
ctxt StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
tree [] FreeVars
pvarset
(HsExpr GhcRn
mb_ret, FreeVars
fvs1) <-
if | L SrcSpanAnnA
_ ApplicativeStmt{} <- forall a. [a] -> a
last [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts' ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. GenLocated l e -> e
unLoc XRec GhcRn (HsExpr GhcRn)
tup, FreeVars
emptyNameSet)
| Bool
otherwise -> do
(HsExpr GhcRn
ret, FreeVars
_) <- forall p. HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupQualifiedDoExpr HsStmtContext GhcRn
ctxt Name
returnMName
let expr :: HsExpr GhcRn
expr = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
ret) XRec GhcRn (HsExpr GhcRn)
tup
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
expr, FreeVars
emptyFVs)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ApplicativeArgMany
{ xarg_app_arg_many :: XApplicativeArgMany GhcRn
xarg_app_arg_many = NoExtField
noExtField
, app_stmts :: [ExprLStmt GhcRn]
app_stmts = [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts'
, final_expr :: HsExpr GhcRn
final_expr = HsExpr GhcRn
mb_ret
, bv_pattern :: LPat GhcRn
bv_pattern = LPat GhcRn
pat
, stmt_context :: HsStmtContext (ApplicativeArgStmCtxPass GhcRn)
stmt_context = HsStmtContext GhcRn
ctxt
}
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2)
segments
:: [(ExprLStmt GhcRn, FreeVars)]
-> [[(ExprLStmt GhcRn, FreeVars)]]
segments :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
segments [(ExprLStmt GhcRn, FreeVars)]
stmts = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall {a :: Pass} {b} {b}.
[[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
-> [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
merge forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk (forall a. [a] -> [a]
reverse [(ExprLStmt GhcRn, FreeVars)]
stmts)
where
allvars :: FreeVars
allvars = [Name] -> FreeVars
mkNameSet (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders forall p. CollectFlag p
CollNoDictBinders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ExprLStmt GhcRn, FreeVars)]
stmts)
merge :: [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
-> [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
merge [] = []
merge ([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
seg : [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
segs)
= case [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
rest of
[] -> [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
seg,Bool
all_lets)]
(([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
s,Bool
s_lets):[([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
ss) | Bool
all_lets Bool -> Bool -> Bool
|| Bool
s_lets
-> ([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
seg forall a. [a] -> [a] -> [a]
++ [(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
s, Bool
all_lets Bool -> Bool -> Bool
&& Bool
s_lets) forall a. a -> [a] -> [a]
: [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
ss
[([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
_otherwise -> ([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
seg,Bool
all_lets) forall a. a -> [a] -> [a]
: [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
rest
where
rest :: [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
rest = [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
-> [([(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)],
Bool)]
merge [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
segs
all_lets :: Bool
all_lets = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (a :: Pass) b. LStmt (GhcPass a) b -> Bool
isLetStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
seg
walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk [] = []
walk ((ExprLStmt GhcRn
stmt,FreeVars
fvs) : [(ExprLStmt GhcRn, FreeVars)]
stmts) = ((ExprLStmt GhcRn
stmt,FreeVars
fvs) forall a. a -> [a] -> [a]
: [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
seg) forall a. a -> [a] -> [a]
: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest
where ([(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
seg,[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest) = FreeVars
-> [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)],
[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)])
chunter FreeVars
fvs' [(ExprLStmt GhcRn, FreeVars)]
stmts
(FreeVars
_, FreeVars
fvs') = GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> FreeVars -> (FreeVars, FreeVars)
stmtRefs ExprLStmt GhcRn
stmt FreeVars
fvs
chunter :: FreeVars
-> [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)],
[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)])
chunter FreeVars
_ [] = ([], [])
chunter FreeVars
vars ((GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt,FreeVars
fvs) : [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest)
| Bool -> Bool
not (FreeVars -> Bool
isEmptyNameSet FreeVars
vars)
Bool -> Bool -> Bool
|| ExprLStmt GhcRn -> Bool
isStrictPatternBind GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt
= ((GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt,FreeVars
fvs) forall a. a -> [a] -> [a]
: [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
chunk, [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest')
where ([(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
chunk,[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest') = FreeVars
-> [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)],
[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)])
chunter FreeVars
vars' [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest
(FreeVars
pvars, FreeVars
evars) = GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> FreeVars -> (FreeVars, FreeVars)
stmtRefs GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt FreeVars
fvs
vars' :: FreeVars
vars' = (FreeVars
vars FreeVars -> FreeVars -> FreeVars
`minusNameSet` FreeVars
pvars) FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
evars
chunter FreeVars
_ [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest = ([], [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest)
stmtRefs :: GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> FreeVars -> (FreeVars, FreeVars)
stmtRefs GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt FreeVars
fvs
| forall (a :: Pass) b. LStmt (GhcPass a) b -> Bool
isLetStmt GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 (forall (idL :: Pass) (idR :: Pass) body.
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders forall p. CollectFlag p
CollNoDictBinders (forall l e. GenLocated l e -> e
unLoc GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
isStrictPatternBind (L SrcSpanAnnA
_ (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
_)) = forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat GhcRn
pat
isStrictPatternBind ExprLStmt GhcRn
_ = Bool
False
isStrictPattern :: LPat (GhcPass p) -> Bool
isStrictPattern :: forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
lpat =
case forall l e. GenLocated l e -> e
unLoc LPat (GhcPass p)
lpat of
WildPat{} -> Bool
False
VarPat{} -> Bool
False
LazyPat{} -> Bool
False
AsPat XAsPat (GhcPass p)
_ LIdP (GhcPass p)
_ LPat (GhcPass p)
p -> forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
ParPat XParPat (GhcPass p)
_ LPat (GhcPass p)
p -> forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
ViewPat XViewPat (GhcPass p)
_ LHsExpr (GhcPass p)
_ LPat (GhcPass p)
p -> forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
SigPat XSigPat (GhcPass p)
_ LPat (GhcPass p)
p HsPatSigType (NoGhcTc (GhcPass p))
_ -> forall (p :: Pass). LPat (GhcPass p) -> Bool
isStrictPattern LPat (GhcPass p)
p
BangPat{} -> Bool
True
ListPat{} -> Bool
True
TuplePat{} -> Bool
True
SumPat{} -> Bool
True
ConPat{} -> Bool
True
LitPat{} -> Bool
True
NPat{} -> Bool
True
NPlusKPat{} -> Bool
True
SplicePat{} -> Bool
True
XPat{} -> forall a. String -> a
panic String
"isStrictPattern: XPat"
hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
hasRefutablePattern DynFlags
dflags (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 (forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcRn
pat)
hasRefutablePattern DynFlags
_ ApplicativeArg GhcRn
_ = Bool
False
isLetStmt :: LStmt (GhcPass a) b -> Bool
isLetStmt :: forall (a :: Pass) b. LStmt (GhcPass a) b -> Bool
isLetStmt (L Anno (StmtLR (GhcPass a) (GhcPass a) b)
_ LetStmt{}) = Bool
True
isLetStmt LStmt (GhcPass a) b
_ = Bool
False
splitSegment
:: [(ExprLStmt GhcRn, FreeVars)]
-> ( [(ExprLStmt GhcRn, FreeVars)]
, [(ExprLStmt GhcRn, FreeVars)] )
splitSegment :: [(ExprLStmt GhcRn, FreeVars)]
-> ([(ExprLStmt GhcRn, FreeVars)], [(ExprLStmt GhcRn, FreeVars)])
splitSegment [(ExprLStmt GhcRn, FreeVars)
one,(ExprLStmt GhcRn, FreeVars)
two] = ([(ExprLStmt GhcRn, FreeVars)
one],[(ExprLStmt GhcRn, FreeVars)
two])
splitSegment [(ExprLStmt GhcRn, FreeVars)]
stmts
| Just ([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
lets,[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
binds,[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
rest) <- forall (body :: * -> *).
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> Maybe
([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)],
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)],
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)])
slurpIndependentStmts [(ExprLStmt GhcRn, FreeVars)]
stmts
= if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
lets)
then ([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
lets, [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
bindsforall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
rest)
else ([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
letsforall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
binds, [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
rest)
| Bool
otherwise
= case [(ExprLStmt GhcRn, FreeVars)]
stmts of
((ExprLStmt GhcRn, FreeVars)
x:[(ExprLStmt GhcRn, FreeVars)]
xs) -> ([(ExprLStmt GhcRn, FreeVars)
x],[(ExprLStmt GhcRn, FreeVars)]
xs)
[(ExprLStmt GhcRn, FreeVars)]
_other -> ([(ExprLStmt GhcRn, FreeVars)]
stmts,[])
slurpIndependentStmts
:: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
, [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
, [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] )
slurpIndependentStmts :: forall (body :: * -> *).
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> Maybe
([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)],
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)],
[(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)])
slurpIndependentStmts [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
stmts = forall {p :: Pass} {idR} {body} {body} {idR} {l}.
(IdGhcP p ~ Name,
XLetStmt (GhcPass p) idR body ~ XLetStmt (GhcPass p) idR body,
XBindStmt (GhcPass p) idR body ~ XBindStmt (GhcPass p) idR body,
IsPass p) =>
[(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 (LocatedA (body GhcRn)), FreeVars)]
stmts
where
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
xbs LPat (GhcPass p)
pat body
body), FreeVars
fvs): [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest)
| FreeVars -> FreeVars -> Bool
disjointNameSet FreeVars
bndrs FreeVars
fvs Bool -> Bool -> Bool
&& Bool -> Bool
not (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 ((forall l e. l -> e -> GenLocated l e
L l
loc (forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt (GhcPass p) idR body
xbs LPat (GhcPass p)
pat body
body), FreeVars
fvs) 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 (forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders forall p. CollectFlag p
CollNoDictBinders LPat (GhcPass p)
pat)
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 HsLocalBindsLR (GhcPass p) idR
binds), FreeVars
fvs) : [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest)
| FreeVars -> FreeVars -> Bool
disjointNameSet FreeVars
bndrs 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 ((forall l e. l -> e -> GenLocated l e
L l
loc (forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt (GhcPass p) idR body
noExtField HsLocalBindsLR (GhcPass p) idR
binds), FreeVars
fvs) 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)]
_ = 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)]
_ = 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 = forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets, forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep, [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
stmts)
mkApplicativeStmt
:: HsStmtContext GhcRn
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt :: HsStmtContext GhcRn
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsStmtContext GhcRn
ctxt [ApplicativeArg GhcRn]
args Bool
need_join [ExprLStmt GhcRn]
body_stmts
= do { (SyntaxExprRn
fmap_op, FreeVars
fvs1) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
fmapName
; (SyntaxExprRn
ap_op, FreeVars
fvs2) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
apAName
; (Maybe SyntaxExprRn
mb_join, FreeVars
fvs3) <-
if Bool
need_join then
do { (SyntaxExprRn
join_op, FreeVars
fvs) <- HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContext GhcRn
ctxt Name
joinMName
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just SyntaxExprRn
join_op, FreeVars
fvs) }
else
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyNameSet)
; let applicative_stmt :: GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
applicative_stmt = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
ApplicativeStmt NoExtField
noExtField
(forall a b. [a] -> [b] -> [(a, b)]
zip (SyntaxExprRn
fmap_op forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat SyntaxExprRn
ap_op) [ApplicativeArg GhcRn]
args)
Maybe SyntaxExprRn
mb_join
; forall (m :: * -> *) a. Monad m => a -> m a
return ( GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
applicative_stmt forall a. a -> [a] -> [a]
: [ExprLStmt GhcRn]
body_stmts
, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs3) }
needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> (Bool, [ExprLStmt GhcRn])
needJoin :: MonadNames -> [ExprLStmt GhcRn] -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
_monad_names [] = (Bool
False, [])
needJoin MonadNames
monad_names [L SrcSpanAnnA
loc (LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ GenLocated SrcSpanAnnA (HsExpr GhcRn)
e Maybe Bool
_ SyntaxExpr GhcRn
t)]
| Just (XRec GhcRn (HsExpr GhcRn)
arg, Bool
wasDollar) <- MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe (XRec GhcRn (HsExpr GhcRn), Bool)
isReturnApp MonadNames
monad_names GenLocated SrcSpanAnnA (HsExpr GhcRn)
e =
(Bool
False, [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt NoExtField
noExtField XRec GhcRn (HsExpr GhcRn)
arg (forall a. a -> Maybe a
Just Bool
wasDollar) SyntaxExpr GhcRn
t)])
needJoin MonadNames
_monad_names [ExprLStmt GhcRn]
stmts = (Bool
True, [ExprLStmt GhcRn]
stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe (LHsExpr GhcRn, Bool)
isReturnApp :: MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe (XRec GhcRn (HsExpr GhcRn), Bool)
isReturnApp MonadNames
monad_names (L SrcSpanAnnA
_ (HsPar XPar GhcRn
_ XRec GhcRn (HsExpr GhcRn)
expr)) = MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe (XRec GhcRn (HsExpr GhcRn), Bool)
isReturnApp MonadNames
monad_names XRec GhcRn (HsExpr GhcRn)
expr
isReturnApp MonadNames
monad_names (L SrcSpanAnnA
_ HsExpr GhcRn
e) = case HsExpr GhcRn
e of
OpApp XOpApp GhcRn
_ XRec GhcRn (HsExpr GhcRn)
l XRec GhcRn (HsExpr GhcRn)
op XRec GhcRn (HsExpr GhcRn)
r | GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
l, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_dollar XRec GhcRn (HsExpr GhcRn)
op -> forall a. a -> Maybe a
Just (XRec GhcRn (HsExpr GhcRn)
r, Bool
True)
HsApp XApp GhcRn
_ XRec GhcRn (HsExpr GhcRn)
f XRec GhcRn (HsExpr GhcRn)
arg | GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
f -> forall a. a -> Maybe a
Just (XRec GhcRn (HsExpr GhcRn)
arg, Bool
False)
HsExpr GhcRn
_otherwise -> forall a. Maybe a
Nothing
where
is_var :: (IdP p -> Bool) -> GenLocated l (HsExpr p) -> Bool
is_var IdP p -> Bool
f (L l
_ (HsPar XPar p
_ XRec p (HsExpr p)
e)) = (IdP p -> Bool) -> GenLocated l (HsExpr p) -> Bool
is_var IdP p -> Bool
f XRec p (HsExpr p)
e
is_var IdP p -> Bool
f (L l
_ (HsAppType XAppTypeE p
_ XRec p (HsExpr p)
e LHsWcType (NoGhcTc p)
_)) = (IdP p -> Bool) -> GenLocated l (HsExpr p) -> Bool
is_var IdP p -> Bool
f XRec p (HsExpr p)
e
is_var IdP p -> Bool
f (L l
_ (HsVar XVar p
_ (L l
_ IdP p
r))) = IdP p -> Bool
f IdP p
r
is_var IdP p -> Bool
_ GenLocated l (HsExpr p)
_ = Bool
False
is_return :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return = forall {p} {l} {l}.
(XRec p (HsExpr p) ~ GenLocated l (HsExpr p),
XRec p (IdP p) ~ GenLocated l (IdP p)) =>
(IdP p -> Bool) -> GenLocated l (HsExpr p) -> Bool
is_var (\IdP GhcRn
n -> IdP GhcRn
n forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
return_name MonadNames
monad_names
Bool -> Bool -> Bool
|| IdP GhcRn
n forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
pure_name MonadNames
monad_names)
is_dollar :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_dollar = forall {p} {l} {l}.
(XRec p (HsExpr p) ~ GenLocated l (HsExpr p),
XRec p (IdP p) ~ GenLocated l (IdP p)) =>
(IdP p -> Bool) -> GenLocated l (HsExpr p) -> Bool
is_var (forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey)
checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
checkEmptyStmts :: HsStmtContext GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContext GhcRn
ctxt
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall id. HsStmtContext id -> Bool
okEmpty HsStmtContext GhcRn
ctxt) (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsStmtContext GhcRn -> SDoc
emptyErr HsStmtContext GhcRn
ctxt))
okEmpty :: HsStmtContext a -> Bool
okEmpty :: forall id. HsStmtContext id -> Bool
okEmpty (PatGuard {}) = Bool
True
okEmpty HsStmtContext a
_ = Bool
False
emptyErr :: HsStmtContext GhcRn -> SDoc
emptyErr :: HsStmtContext GhcRn -> SDoc
emptyErr (ParStmtCtxt {}) = String -> SDoc
text String
"Empty statement group in parallel comprehension"
emptyErr (TransStmtCtxt {}) = String -> SDoc
text String
"Empty statement group preceding 'group' or 'then'"
emptyErr HsStmtContext GhcRn
ctxt = String -> SDoc
text String
"Empty" SDoc -> SDoc -> SDoc
<+> forall p. (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc
pprStmtContext HsStmtContext GhcRn
ctxt
checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt :: forall (body :: * -> *).
AnnoBody body =>
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContext GhcRn
ctxt lstmt :: LStmt GhcPs (LocatedA (body GhcPs))
lstmt@(L SrcSpanAnnA
loc StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt)
= case HsStmtContext GhcRn
ctxt of
HsStmtContext GhcRn
ListComp -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_comp
HsStmtContext GhcRn
MonadComp -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_comp
HsStmtContext GhcRn
ArrowExpr -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
DoExpr{} -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
MDoExpr{} -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
HsStmtContext GhcRn
_ -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_other
where
check_do :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
= case StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt of
BodyStmt XBodyStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ LocatedA (body GhcPs)
e SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LocatedA (body GhcPs)
e))
LastStmt {} -> forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
lstmt
StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
_ -> do { SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang SDoc
last_error Int
2 (forall a. Outputable a => a -> SDoc
ppr StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt)); forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
lstmt }
last_error :: SDoc
last_error = (String -> SDoc
text String
"The last statement in" SDoc -> SDoc -> SDoc
<+> forall p. (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc
pprAStmtContext HsStmtContext GhcRn
ctxt
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be an expression")
check_comp :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_comp
= case StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt of
LastStmt {} -> forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
lstmt
StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkLastStmt" (forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
lstmt)
check_other :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_other
= do { forall (body :: * -> *).
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext GhcRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt; forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
lstmt }
checkStmt :: HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM ()
checkStmt :: forall (body :: * -> *).
HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContext GhcRn
ctxt (L Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
_ StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt)
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext GhcRn
ctxt StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt of
Validity
IsValid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NotValid SDoc
extra -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
extra) }
where
msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Unexpected" SDoc -> SDoc -> SDoc
<+> forall (a :: Pass) body. Stmt (GhcPass a) body -> SDoc
pprStmtCat StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"statement")
, String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> forall p. (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc
pprAStmtContext HsStmtContext GhcRn
ctxt ]
pprStmtCat :: Stmt (GhcPass a) body -> SDoc
pprStmtCat :: forall (a :: Pass) body. Stmt (GhcPass a) body -> SDoc
pprStmtCat (TransStmt {}) = String -> SDoc
text String
"transform"
pprStmtCat (LastStmt {}) = String -> SDoc
text String
"return expression"
pprStmtCat (BodyStmt {}) = String -> SDoc
text String
"body"
pprStmtCat (BindStmt {}) = String -> SDoc
text String
"binding"
pprStmtCat (LetStmt {}) = String -> SDoc
text String
"let"
pprStmtCat (RecStmt {}) = String -> SDoc
text String
"rec"
pprStmtCat (ParStmt {}) = String -> SDoc
text String
"parallel"
pprStmtCat (ApplicativeStmt {}) = forall a. String -> a
panic String
"pprStmtCat: ApplicativeStmt"
emptyInvalid :: Validity
emptyInvalid :: Validity
emptyInvalid = SDoc -> Validity
NotValid SDoc
Outputable.empty
okStmt, okDoStmt, okCompStmt, okParStmt
:: DynFlags -> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case HsStmtContext GhcRn
ctxt of
PatGuard {} -> forall (body :: * -> *).
Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okPatGuardStmt Stmt GhcPs (LocatedA (body GhcPs))
stmt
ParStmtCtxt HsStmtContext GhcRn
ctxt -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okParStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
DoExpr{} -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
MDoExpr{} -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsStmtContext GhcRn
ArrowExpr -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsStmtContext GhcRn
GhciStmtCtxt -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsStmtContext GhcRn
ListComp -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsStmtContext GhcRn
MonadComp -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
TransStmtCtxt HsStmtContext GhcRn
ctxt -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okPatGuardStmt :: forall (body :: * -> *).
Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okPatGuardStmt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
BodyStmt {} -> Validity
IsValid
BindStmt {} -> Validity
IsValid
LetStmt {} -> Validity
IsValid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> Validity
emptyInvalid
okParStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okParStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (HsIPBinds {}) -> Validity
emptyInvalid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
okDoStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okDoStmt DynFlags
dflags HsStmtContext GhcRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
RecStmt {}
| Extension
LangExt.RecursiveDo Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity
IsValid
| HsStmtContext GhcRn
ArrowExpr <- HsStmtContext GhcRn
ctxt -> Validity
IsValid
| Bool
otherwise -> SDoc -> Validity
NotValid (String -> SDoc
text String
"Use RecursiveDo")
BindStmt {} -> Validity
IsValid
LetStmt {} -> Validity
IsValid
BodyStmt {} -> Validity
IsValid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> Validity
emptyInvalid
okCompStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity
okCompStmt DynFlags
dflags HsStmtContext GhcRn
_ Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (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 -> SDoc -> Validity
NotValid (String -> SDoc
text String
"Use ParallelListComp")
TransStmt {}
| Extension
LangExt.TransformListComp Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity
IsValid
| Bool
otherwise -> SDoc -> Validity
NotValid (String -> SDoc
text String
"Use TransformListComp")
RecStmt {} -> Validity
emptyInvalid
LastStmt {} -> Validity
emptyInvalid
ApplicativeStmt {} -> Validity
emptyInvalid
checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
checkTupleSection :: [HsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [HsTupArg GhcPs]
args
= do { Bool
tuple_section <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TupleSections
; Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkErr (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (p :: Pass). HsTupArg (GhcPass p) -> Bool
tupArgPresent [HsTupArg GhcPs]
args Bool -> Bool -> Bool
|| Bool
tuple_section) SDoc
msg }
where
msg :: SDoc
msg = String -> SDoc
text String
"Illegal tuple section: use TupleSections"
sectionErr :: HsExpr GhcPs -> SDoc
sectionErr :: HsExpr GhcPs -> SDoc
sectionErr HsExpr GhcPs
expr
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A section must be enclosed in parentheses")
Int
2 (String -> SDoc
text String
"thus:" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
parens (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
expr)))
badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds :: forall a. Outputable a => SDoc -> a -> SDoc
badIpBinds SDoc
what a
binds
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Implicit-parameter bindings illegal in" SDoc -> SDoc -> SDoc
<+> SDoc
what)
Int
2 (forall a. Outputable a => a -> SDoc
ppr a
binds)
monadFailOp :: LPat GhcPs
-> HsStmtContext GhcRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp :: LPat GhcPs
-> HsStmtContext GhcRn -> RnM (FailOperator GhcRn, FreeVars)
monadFailOp LPat GhcPs
pat HsStmtContext GhcRn
ctxt = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if | forall (p :: Pass).
OutputableBndrId p =>
DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat DynFlags
dflags LPat GhcPs
pat -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
| Bool -> Bool
not (forall id. HsStmtContext id -> Bool
isMonadStmtContext HsStmtContext GhcRn
ctxt) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FreeVars
emptyFVs)
| Bool
otherwise -> forall p. HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp HsStmtContext GhcRn
ctxt
getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp :: forall p. HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp HsStmtContext p
ctxt
= do { Bool
xOverloadedStrings <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings) forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool
xRebindableSyntax <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.RebindableSyntax) forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; (SyntaxExprRn
fail, FreeVars
fvs) <- Bool
-> Bool -> IOEnv (Env TcGblEnv TcLclEnv) (SyntaxExprRn, FreeVars)
reallyGetMonadFailOp Bool
xRebindableSyntax Bool
xOverloadedStrings
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just SyntaxExprRn
fail, FreeVars
fvs)
}
where
isQualifiedDo :: Bool
isQualifiedDo = forall a. Maybe a -> Bool
isJust (forall p. HsStmtContext p -> Maybe ModuleName
qualifiedDoModuleName_maybe HsStmtContext p
ctxt)
reallyGetMonadFailOp :: Bool
-> Bool -> IOEnv (Env TcGblEnv TcLclEnv) (SyntaxExprRn, FreeVars)
reallyGetMonadFailOp Bool
rebindableSyntax Bool
overloadedStrings
| (Bool
isQualifiedDo Bool -> Bool -> Bool
|| Bool
rebindableSyntax) Bool -> Bool -> Bool
&& Bool
overloadedStrings = do
(HsExpr GhcRn
failExpr, FreeVars
failFvs) <- forall p. HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupQualifiedDoExpr HsStmtContext p
ctxt Name
failMName
(HsExpr GhcRn
fromStringExpr, FreeVars
fromStringFvs) <- Name -> RnM (HsExpr GhcRn, FreeVars)
lookupSyntaxExpr Name
fromStringName
let arg_lit :: OccName
arg_lit = String -> OccName
mkVarOcc String
"arg"
Name
arg_name <- forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
arg_lit
let arg_syn_expr :: XRec GhcRn (HsExpr GhcRn)
arg_syn_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
arg_name
XRec GhcRn (HsExpr GhcRn)
body :: LHsExpr GhcRn =
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcRn
failExpr)
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn
fromStringExpr) XRec GhcRn (HsExpr GhcRn)
arg_syn_expr)
let HsExpr GhcRn
failAfterFromStringExpr :: HsExpr GhcRn =
forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA Name
arg_name] XRec GhcRn (HsExpr GhcRn)
body
let SyntaxExpr GhcRn
failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
HsExpr GhcRn -> SyntaxExprRn
mkSyntaxExpr HsExpr GhcRn
failAfterFromStringExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SyntaxExpr GhcRn
failAfterFromStringSynExpr, FreeVars
failFvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fromStringFvs)
| Bool
otherwise = forall p.
HsStmtContext p -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo HsStmtContext p
ctxt Name
failMName
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps :: Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
fun [XRec GhcRn (HsExpr GhcRn)]
args = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp (Name -> HsExpr GhcRn
genHsVar Name
fun) [XRec GhcRn (HsExpr GhcRn)]
args
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp :: HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp HsExpr GhcRn
fun XRec GhcRn (HsExpr GhcRn)
arg = forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
fun) XRec GhcRn (HsExpr GhcRn)
arg
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar :: Name -> XRec GhcRn (HsExpr GhcRn)
genLHsVar Name
nm = forall a an. a -> LocatedAn an a
wrapGenSpan forall a b. (a -> b) -> a -> b
$ Name -> HsExpr GhcRn
genHsVar Name
nm
genHsVar :: Name -> HsExpr GhcRn
genHsVar :: Name -> HsExpr GhcRn
genHsVar Name
nm = forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
wrapGenSpan Name
nm
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType HsExpr GhcRn
expr = forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
noExtField (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
expr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
wrapGenSpan
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit = forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText
wrapGenSpan :: a -> LocatedAn an a
wrapGenSpan :: forall a an. a -> LocatedAn an a
wrapGenSpan a
x = forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
generatedSrcSpan) a
x
mkExpandedExpr
:: HsExpr GhcRn
-> HsExpr GhcRn
-> HsExpr GhcRn
mkExpandedExpr :: HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
mkExpandedExpr HsExpr GhcRn
a HsExpr GhcRn
b = forall p. XXExpr p -> HsExpr p
XExpr (forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
a HsExpr GhcRn
b)
mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn
mkGetField :: Name
-> XRec GhcRn (HsExpr GhcRn) -> Located FastString -> HsExpr GhcRn
mkGetField Name
get_field XRec GhcRn (HsExpr GhcRn)
arg Located FastString
field = forall l e. GenLocated l e -> e
unLoc (forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> Located FastString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field [XRec GhcRn (HsExpr GhcRn)
arg] Located FastString
field)
mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
mkSetField :: Name
-> XRec GhcRn (HsExpr GhcRn)
-> Located FastString
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
mkSetField Name
set_field XRec GhcRn (HsExpr GhcRn)
a (L SrcSpan
_ FastString
field) XRec GhcRn (HsExpr GhcRn)
b =
HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp (HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp (Name -> HsExpr GhcRn
genHsVar Name
set_field HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
`genAppType` FastString -> HsType GhcRn
genHsTyLit FastString
field) XRec GhcRn (HsExpr GhcRn)
a) XRec GhcRn (HsExpr GhcRn)
b
mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]
mkGet :: Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> Located FastString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field l :: [XRec GhcRn (HsExpr GhcRn)]
l@(XRec GhcRn (HsExpr GhcRn)
r : [XRec GhcRn (HsExpr GhcRn)]
_) (L SrcSpan
_ FastString
field) =
forall a an. a -> LocatedAn an a
wrapGenSpan (HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn) -> HsExpr GhcRn
genHsApp (Name -> HsExpr GhcRn
genHsVar Name
get_field HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
`genAppType` FastString -> HsType GhcRn
genHsTyLit FastString
field) XRec GhcRn (HsExpr GhcRn)
r) forall a. a -> [a] -> [a]
: [XRec GhcRn (HsExpr GhcRn)]
l
mkGet Name
_ [] Located FastString
_ = forall a. String -> a
panic String
"mkGet : The impossible has happened!"
mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
mkSet :: Name
-> XRec GhcRn (HsExpr GhcRn)
-> (Located FastString, XRec GhcRn (HsExpr GhcRn))
-> XRec GhcRn (HsExpr GhcRn)
mkSet Name
set_field XRec GhcRn (HsExpr GhcRn)
acc (Located FastString
field, XRec GhcRn (HsExpr GhcRn)
g) = forall a an. a -> LocatedAn an a
wrapGenSpan (Name
-> XRec GhcRn (HsExpr GhcRn)
-> Located FastString
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
mkSetField Name
set_field XRec GhcRn (HsExpr GhcRn)
g Located FastString
field XRec GhcRn (HsExpr GhcRn)
acc)
mkProjection :: Name -> Name -> NonEmpty (Located FieldLabelString) -> HsExpr GhcRn
mkProjection :: Name -> Name -> NonEmpty (Located FastString) -> HsExpr GhcRn
mkProjection Name
getFieldName Name
circName (Located FastString
field :| [Located FastString]
fields) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcRn -> Located FastString -> HsExpr GhcRn
f (Located FastString -> HsExpr GhcRn
proj Located FastString
field) [Located FastString]
fields
where
f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn
f :: HsExpr GhcRn -> Located FastString -> HsExpr GhcRn
f HsExpr GhcRn
acc Located FastString
field = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
circName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a an. a -> LocatedAn an a
wrapGenSpan [Located FastString -> HsExpr GhcRn
proj Located FastString
field, HsExpr GhcRn
acc]
proj :: Located FieldLabelString -> HsExpr GhcRn
proj :: Located FastString -> HsExpr GhcRn
proj (L SrcSpan
_ FastString
f) = Name -> HsExpr GhcRn
genHsVar Name
getFieldName HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
`genAppType` FastString -> HsType GhcRn
genHsTyLit FastString
f
mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
mkProjUpdateSetField :: Name
-> Name
-> LHsRecUpdProj GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
mkProjUpdateSetField Name
get_field Name
set_field (L SrcSpanAnnA
_ (HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = (L SrcSpan
_ (FieldLabelStrings [Located (HsFieldLabel GhcRn)]
flds')), hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg } ))
= let {
; flds :: [Located FastString]
flds = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsFieldLabel p -> Located FastString
hflLabel)) [Located (HsFieldLabel GhcRn)]
flds'
; final :: Located FastString
final = forall a. [a] -> a
last [Located FastString]
flds
; fields :: [Located FastString]
fields = forall a. [a] -> [a]
init [Located FastString]
flds
; getters :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters = \GenLocated SrcSpanAnnA (HsExpr GhcRn)
a -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> Located FastString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field) [GenLocated SrcSpanAnnA (HsExpr GhcRn)
a] [Located FastString]
fields
; zips :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [(Located FastString, GenLocated SrcSpanAnnA (HsExpr GhcRn))]
zips = \GenLocated SrcSpanAnnA (HsExpr GhcRn)
a -> (Located FastString
final, forall a. [a] -> a
head (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters GenLocated SrcSpanAnnA (HsExpr GhcRn)
a)) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
reverse [Located FastString]
fields) (forall a. [a] -> [a]
tail (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters GenLocated SrcSpanAnnA (HsExpr GhcRn)
a))
}
in (\XRec GhcRn (HsExpr GhcRn)
a -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Name
-> XRec GhcRn (HsExpr GhcRn)
-> (Located FastString, XRec GhcRn (HsExpr GhcRn))
-> XRec GhcRn (HsExpr GhcRn)
mkSet Name
set_field) GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [(Located FastString, GenLocated SrcSpanAnnA (HsExpr GhcRn))]
zips XRec GhcRn (HsExpr GhcRn)
a))
mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn
mkRecordDotUpd :: Name
-> Name
-> XRec GhcRn (HsExpr GhcRn)
-> [LHsRecUpdProj GhcRn]
-> HsExpr GhcRn
mkRecordDotUpd Name
get_field Name
set_field XRec GhcRn (HsExpr GhcRn)
exp [LHsRecUpdProj GhcRn]
updates = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate (forall l e. GenLocated l e -> e
unLoc XRec GhcRn (HsExpr GhcRn)
exp) [LHsRecUpdProj GhcRn]
updates
where
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate HsExpr GhcRn
acc LHsRecUpdProj GhcRn
lpu = forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ (Name
-> Name
-> LHsRecUpdProj GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
mkProjUpdateSetField Name
get_field Name
set_field LHsRecUpdProj GhcRn
lpu) (forall a an. a -> LocatedAn an a
wrapGenSpan HsExpr GhcRn
acc)
rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
rnHsUpdProjs [LHsRecUpdProj GhcPs]
us = do
([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
u, [FreeVars]
fvs) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj [LHsRecUpdProj GhcPs]
us
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
SrcSpanAnnA
(HsRecField'
(FieldLabelStrings GhcRn) (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
u, [FreeVars] -> FreeVars
plusFVs [FreeVars]
fvs)
where
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj (L SrcSpanAnnA
l (HsRecField XHsRecField (FieldLabelStrings GhcPs)
_ Located (FieldLabelStrings GhcPs)
fs GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
pun))
= do { (GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg, FreeVars
fv) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsRecField { hsRecFieldAnn :: XHsRecField (FieldLabelStrings GhcRn)
hsRecFieldAnn = forall a. EpAnn a
noAnn
, hsRecFieldLbl :: GenLocated SrcSpan (FieldLabelStrings GhcRn)
hsRecFieldLbl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings Located (FieldLabelStrings GhcPs)
fs
, hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg
, hsRecPun :: Bool
hsRecPun = Bool
pun}), FreeVars
fv) }