{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Rename.Expr (
rnLExpr, rnExpr, rnStmts,
AnnoBody, UnexpectedStatement(..)
) where
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env ( isBrackStage )
import GHC.Tc.Utils.Monad
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
, rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice
, rnUntypedSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
import GHC.Rename.Pat
import GHC.Driver.DynFlags
import GHC.Builtin.Names
import GHC.Builtin.Types ( nilDataConName )
import GHC.Unit.Module ( getModule, isInteractiveModule )
import GHC.Types.Basic (TypeOrKind (TypeLevel))
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.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
import Data.List (unzip4, minimumBy)
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
import GHC.Driver.Env (HscEnv)
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]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ls FreeVars
forall a. UniqSet a
emptyUniqSet
where
rnExprs' :: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
rnExprs' [] FreeVars
acc = ([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 { (expr', fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
; let acc' = FreeVars
acc FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvExpr
; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
; return (expr':exprs', fvExprs) }
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr :: LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr = (HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: LocatedA Name -> TcM (HsExpr GhcRn, FreeVars)
finishHsVar (L SrcSpanAnnA
l Name
name)
= do { this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
; return (HsVar noExtField (L (l2l l) name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar :: RdrName -> TcM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
v = do
deferOutofScopeVariables <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DeferOutOfScopeVariables
unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())
return (HsUnboundVar noExtField v, emptyFVs)
rnExpr :: HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr (HsVar XVar GhcPs
_ (L SrcSpanAnnN
l RdrName
v))
= do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; mb_gre <- lookupExprOccRn v
; case mb_gre of {
Maybe GlobalRdrElt
Nothing -> RdrName -> TcM (HsExpr GhcRn, FreeVars)
rnUnboundVar RdrName
v ;
Just GlobalRdrElt
gre ->
do { let nm :: Name
nm = GlobalRdrElt -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrElt
gre
info :: GREInfo
info = GlobalRdrElt -> GREInfo
greInfo GlobalRdrElt
gre
; if | IAmRecField RecFieldInfo
fld_info <- GREInfo
info
-> do { let sel_name :: Name
sel_name = FieldLabel -> Name
flSelector (FieldLabel -> Name) -> FieldLabel -> Name
forall a b. (a -> b) -> a -> b
$ RecFieldInfo -> FieldLabel
recFieldLabel RecFieldInfo
fld_info
; this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; when (nameIsLocalOrFrom this_mod sel_name) $
checkThLocalName sel_name
; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
}
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nilDataConName
, Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedLists DynFlags
dflags
-> HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr (XExplicitList GhcPs -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
AnnList ()
forall a. NoAnn a => a
noAnn [])
| Bool
otherwise
-> LocatedA Name -> TcM (HsExpr GhcRn, FreeVars)
finishHsVar (SrcSpanAnnA -> Name -> LocatedA Name
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
l) Name
nm)
}}}
rnExpr (HsIPVar XIPVar GhcPs
x HsIPName
v)
= (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XIPVar GhcRn -> HsIPName -> HsExpr GhcRn
forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar XIPVar GhcPs
XIPVar GhcRn
x HsIPName
v, FreeVars
emptyFVs)
rnExpr (HsUnboundVar XUnboundVar GhcPs
_ RdrName
v)
= (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XUnboundVar GhcRn -> RdrName -> HsExpr GhcRn
forall p. XUnboundVar p -> RdrName -> HsExpr p
HsUnboundVar XUnboundVar GhcRn
NoExtField
noExtField RdrName
v, FreeVars
emptyFVs)
rnExpr (HsOverLabel XOverLabel GhcPs
src FastString
v)
= do { (from_label, fvs) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
fromLabelClassOpName
; return ( mkExpandedExpr (HsOverLabel src v) $
HsAppType noExtField (genLHsVar from_label) hs_ty_arg
, fvs ) }
where
hs_ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
hs_ty_arg = GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a b. (a -> b) -> a -> b
$
XTyLit GhcRn -> HsTyLit GhcRn -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit GhcRn
NoExtField
noExtField (XStrTy GhcRn -> FastString -> HsTyLit GhcRn
forall pass. XStrTy pass -> FastString -> HsTyLit pass
HsStrTy XStrTy GhcRn
SourceText
NoSourceText FastString
v)
rnExpr (HsLit XLitE GhcPs
x HsLit GhcPs
lit) | Just (XHsString GhcPs
src, FastString
s) <- HsLit GhcPs -> Maybe (XHsString GhcPs, FastString)
stringLike HsLit GhcPs
lit
= do { opt_OverloadedStrings <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
; return (HsLit x (convertLit lit), emptyFVs) } }
where
stringLike :: HsLit GhcPs -> Maybe (XHsString GhcPs, FastString)
stringLike = \case
HsString XHsString GhcPs
src FastString
s -> (XHsString GhcPs, FastString)
-> Maybe (XHsString GhcPs, FastString)
forall a. a -> Maybe a
Just (XHsString GhcPs
src, FastString
s)
HsMultilineString XHsMultilineString GhcPs
src FastString
s -> (XHsString GhcPs, FastString)
-> Maybe (XHsString GhcPs, FastString)
forall a. a -> Maybe a
Just (XHsMultilineString GhcPs
XHsString GhcPs
src, FastString
s)
HsLit GhcPs
_ -> Maybe (XHsString GhcPs, FastString)
forall a. Maybe a
Nothing
rnExpr (HsLit XLitE GhcPs
x HsLit GhcPs
lit)
= do { HsLit GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall p. HsLit p -> IOEnv (Env TcGblEnv TcLclEnv) ()
rnLit HsLit GhcPs
lit
; (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
XLitE GhcRn
x (HsLit GhcPs -> HsLit GhcRn
forall (p :: Pass) (p' :: Pass).
(XXLit (GhcPass p) ~ DataConCantHappen) =>
HsLit (GhcPass p) -> HsLit (GhcPass p')
convertLit HsLit GhcPs
lit), FreeVars
emptyFVs) }
rnExpr (HsOverLit XOverLitE GhcPs
x HsOverLit GhcPs
lit)
= do { ((lit', mb_neg), fvs) <- HsOverLit GhcPs
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
forall t.
(XXOverLit t ~ DataConCantHappen) =>
HsOverLit t
-> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit HsOverLit GhcPs
lit
; case mb_neg of
Maybe (HsExpr GhcRn)
Nothing -> (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
XOverLitE GhcRn
x HsOverLit GhcRn
lit', FreeVars
fvs)
Just HsExpr GhcRn
neg ->
(HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA HsExpr GhcRn
neg) (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA (XOverLitE GhcRn -> HsOverLit GhcRn -> HsExpr GhcRn
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
XOverLitE GhcRn
x HsOverLit GhcRn
lit'))
, FreeVars
fvs ) }
rnExpr (HsApp XApp GhcPs
x LHsExpr GhcPs
fun LHsExpr GhcPs
arg)
= do { (fun',fvFun) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
fun
; (arg',fvArg) <- rnLExpr arg
; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
rnExpr (HsAppType XAppTypeE GhcPs
_ LHsExpr GhcPs
fun LHsWcType (NoGhcTc GhcPs)
arg)
= do { type_app <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
; unless type_app $ addErr $ typeAppErr TypeLevel $ hswc_body arg
; (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
; return (HsAppType noExtField fun' arg', fvFun `plusFV` fvArg) }
rnExpr (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
e1 LHsExpr GhcPs
op LHsExpr GhcPs
e2)
= do { (e1', fv_e1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e1
; (e2', fv_e2) <- rnLExpr e2
; (op', fv_op) <- rnLExpr op
; fixity <- case op' of
L SrcSpanAnnA
_ (HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
n)) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFixityRn Name
n
L SrcSpanAnnA
_ (XExpr (HsRecSelRn FieldOcc GhcRn
f)) -> FieldOcc GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
lookupFieldFixityRn FieldOcc GhcRn
f
GenLocated SrcSpanAnnA (HsExpr GhcRn)
_ -> Fixity -> IOEnv (Env TcGblEnv TcLclEnv) Fixity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> FixityDirection -> Fixity
Fixity Int
minPrecedence FixityDirection
InfixL)
; lexical_negation <- xoptM LangExt.LexicalNegation
; let negation_handling | Bool
lexical_negation = NegationHandling
KeepNegationIntact
| Bool
otherwise = NegationHandling
ReassociateNegation
; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
rnExpr (NegApp XNegApp GhcPs
_ LHsExpr GhcPs
e SyntaxExpr GhcPs
_)
= do { (e', fv_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; (neg_name, fv_neg) <- lookupSyntax negateName
; final_e <- mkNegAppRn e' neg_name
; return (final_e, fv_e `plusFV` fv_neg) }
rnExpr (HsGetField XGetField GhcPs
_ LHsExpr GhcPs
e XRec GhcPs (DotFieldOcc GhcPs)
f)
= do { (getField, fv_getField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
getFieldName
; (e, fv_e) <- rnLExpr e
; let f' = DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc (DotFieldOcc GhcPs -> DotFieldOcc GhcRn)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XRec GhcPs (DotFieldOcc GhcPs)
GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)
f
; return ( mkExpandedExpr
(HsGetField noExtField e f')
(mkGetField getField e (fmap (unLoc . dfoLabel) f'))
, fv_e `plusFV` fv_getField ) }
rnExpr (HsProjection XProjection GhcPs
_ NonEmpty (DotFieldOcc GhcPs)
fs)
= do { (getField, fv_getField) <- Name -> RnM (Name, FreeVars)
lookupSyntaxName Name
getFieldName
; circ <- lookupOccRn compose_RDR
; let fs' = (DotFieldOcc GhcPs -> DotFieldOcc GhcRn)
-> NonEmpty (DotFieldOcc GhcPs) -> NonEmpty (DotFieldOcc GhcRn)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc NonEmpty (DotFieldOcc GhcPs)
fs
; return ( mkExpandedExpr
(HsProjection noExtField fs')
(mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs')
, unitFV circ `plusFV` fv_getField) }
rnExpr e :: HsExpr GhcPs
e@(HsTypedBracket XTypedBracket GhcPs
_ LHsExpr GhcPs
br_body) = HsExpr GhcPs -> LHsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnTypedBracket HsExpr GhcPs
e LHsExpr GhcPs
br_body
rnExpr e :: HsExpr GhcPs
e@(HsUntypedBracket XUntypedBracket GhcPs
_ HsQuote GhcPs
br_body) = HsExpr GhcPs -> HsQuote GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnUntypedBracket HsExpr GhcPs
e HsQuote GhcPs
br_body
rnExpr (HsTypedSplice XTypedSplice GhcPs
_ LHsExpr GhcPs
splice) = LHsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnTypedSplice LHsExpr GhcPs
splice
rnExpr (HsUntypedSplice XUntypedSplice GhcPs
_ HsUntypedSplice GhcPs
splice) = HsUntypedSplice GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnUntypedSpliceExpr HsUntypedSplice GhcPs
splice
rnExpr (HsPar XPar GhcPs
_ (L SrcSpanAnnA
loc (section :: HsExpr GhcPs
section@(SectionL {}))))
= do { (section', fvs) <- HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
; return (HsPar noExtField (L loc section'), fvs) }
rnExpr (HsPar XPar GhcPs
_ (L SrcSpanAnnA
loc (section :: HsExpr GhcPs
section@(SectionR {}))))
= do { (section', fvs) <- HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
section
; return (HsPar noExtField (L loc section'), fvs) }
rnExpr (HsPar XPar GhcPs
_ LHsExpr GhcPs
e)
= do { (e', fvs_e) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; return (HsPar noExtField e', fvs_e) }
rnExpr expr :: HsExpr GhcPs
expr@(SectionL {})
= do { TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> TcRnMessage
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }
rnExpr expr :: HsExpr GhcPs
expr@(SectionR {})
= do { TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (HsExpr GhcPs -> TcRnMessage
sectionErr HsExpr GhcPs
expr); HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnSection HsExpr GhcPs
expr }
rnExpr (HsPragE XPragE GhcPs
x HsPragE GhcPs
prag LHsExpr GhcPs
expr)
= do { (expr', fvs_expr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
where
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag (HsPragSCC XSCC GhcPs
x StringLiteral
ann) = XSCC GhcRn -> StringLiteral -> HsPragE GhcRn
forall p. XSCC p -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcPs
XSCC GhcRn
x StringLiteral
ann
rnExpr (HsLam XLam GhcPs
x HsLamVariant
lam_variant MatchGroup GhcPs (LHsExpr GhcPs)
matches)
= do { (matches', fvs_ms) <- HsMatchContextRn
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars))
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)),
FreeVars)
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup (HsLamVariant -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
lam_variant) LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
rnLExpr MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matches
; return (HsLam x lam_variant matches', fvs_ms) }
rnExpr (HsCase XCase GhcPs
_ LHsExpr GhcPs
expr MatchGroup GhcPs (LHsExpr GhcPs)
matches)
= do { (new_expr, e_fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnExpr (HsLet XLet GhcPs
_ HsLocalBinds GhcPs
binds LHsExpr GhcPs
expr)
= HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn -> FreeVars -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars))
-> (HsLocalBinds GhcRn -> FreeVars -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
_ -> do
{ (expr',fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; return (HsLet noExtField binds' expr', fvExpr) }
rnExpr (HsDo XDo GhcPs
_ HsDoFlavour
do_or_lc (L SrcSpanAnnLW
l [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))
= do { ((stmts1, _), fvs1) <-
HsStmtContextRn
-> (HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars))
-> [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> ([Name] -> RnM ((), FreeVars))
-> RnM
(([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)),
FreeVars)],
()),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (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 (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
do_or_lc) HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
[GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts
(\ [Name]
_ -> ((), FreeVars) -> RnM ((), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
rnExpr (ExplicitList XExplicitList GhcPs
_ [LHsExpr GhcPs]
exps)
= do { (exps', fvs) <- [LHsExpr GhcPs] -> RnM ([XRec GhcRn (HsExpr GhcRn)], FreeVars)
rnExprs [LHsExpr GhcPs]
exps
; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; if not opt_OverloadedLists
then return (ExplicitList noExtField exps', fvs)
else
do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
; loc <- getSrcSpanM
; let rn_list = XExplicitList GhcRn -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcRn
NoExtField
noExtField [XRec GhcRn (HsExpr GhcRn)]
[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
exps'
lit_n = Int -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit ([GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
exps)
hs_lit = IntegralLit -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an. NoAnn an => IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit IntegralLit
lit_n
exp_list = GenLocated SrcSpanAnnN Name
-> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps' (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) Name
from_list_n_name) [XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
hs_lit, HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan HsExpr GhcRn
rn_list]
; return ( mkExpandedExpr rn_list exp_list
, fvs `plusFV` fvs') } }
rnExpr (ExplicitTuple XExplicitTuple GhcPs
_ [HsTupArg GhcPs]
tup_args Boxity
boxity)
= do { [HsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [HsTupArg GhcPs]
tup_args
; (tup_args', fvs) <- (HsTupArg GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcRn, FreeVars))
-> [HsTupArg GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) ([HsTupArg GhcRn], [FreeVars])
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
; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }
where
rnTupArg :: HsTupArg GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcRn, FreeVars)
rnTupArg (Present XPresent GhcPs
x LHsExpr GhcPs
e) = do { (e',fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
e
; return (Present x e', fvs) }
rnTupArg (Missing XMissing GhcPs
_) = (HsTupArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsTupArg GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XMissing GhcRn -> HsTupArg GhcRn
forall id. XMissing id -> HsTupArg id
Missing XMissing GhcRn
NoExtField
noExtField, FreeVars
emptyFVs)
rnExpr (ExplicitSum XExplicitSum GhcPs
_ Int
alt Int
arity LHsExpr GhcPs
expr)
= do { (expr', fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; return (ExplicitSum noExtField alt arity expr', fvs) }
rnExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = XRec GhcPs (ConLikeP GhcPs)
con_rdr
, 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 (XRec p RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
dd }) })
= do { con_lname@(L _ con_name) <- GenLocated SrcSpanAnnN RdrName
-> TcRn (GenLocated SrcSpanAnnN Name)
forall ann.
GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRnConstr XRec GhcPs (ConLikeP GhcPs)
GenLocated SrcSpanAnnN RdrName
con_rdr
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_ext :: XHsRecFields GhcRn
rec_ext = NoExtField
XHsRecFields GhcRn
noExtField, rec_flds :: [LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
rec_flds = [LHsRecField GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds', rec_dotdot :: Maybe (XRec GhcRn RecFieldsDotDot)
rec_dotdot = Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (XRec GhcRn RecFieldsDotDot)
dd }
; return (RecordCon { rcon_ext = noExtField
, rcon_con = con_lname, rcon_flds = rec_binds' }
, fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
where
mk_hs_var :: SrcSpan -> IdP p -> HsExpr p
mk_hs_var SrcSpan
l IdP p
n = XVar p -> XRec p (IdP p) -> HsExpr p
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar p
NoExtField
noExtField (l -> IdP p -> GenLocated l (IdP p)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> l
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
l) IdP p
n)
rn_field :: GenLocated
l (HsFieldBind lhs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
l (HsFieldBind lhs (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
rn_field (L l
l HsFieldBind lhs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld) = do { (arg', fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr (HsFieldBind lhs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind lhs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld)
; return (L l (fld { hfbRHS = arg' }), fvs) }
rnExpr (RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = L SrcSpanAnnA
l HsExpr GhcPs
expr, rupd_flds :: forall p. HsExpr p -> LHsRecUpdFields p
rupd_flds = LHsRecUpdFields GhcPs
rbinds })
= SrcSpanAnnA
-> TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
l (TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
case LHsRecUpdFields GhcPs
rbinds of
RegularRecUpdFields { recUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdField p p]
recUpdFields = [LHsRecUpdField GhcPs GhcPs]
flds } ->
do { (e, fv_e) <- HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr HsExpr GhcPs
expr
; (parents, flds, fv_flds) <- rnHsRecUpdFields flds
; let upd_flds =
RegularRecUpdFields
{ xRecUpdFields :: XLHsRecUpdLabels GhcRn
xRecUpdFields = NonEmpty (HsRecUpdParent GhcRn)
XLHsRecUpdLabels GhcRn
parents
, recUpdFields :: [LHsRecUpdField GhcRn GhcRn]
recUpdFields = [LHsRecUpdField GhcRn GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated SrcSpanAnnA (FieldOcc GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
flds }
; return ( RecordUpd noExtField (L l e) upd_flds
, fv_e `plusFV` fv_flds ) }
OverloadedRecUpdFields { olRecUpdFields :: forall p. LHsRecUpdFields p -> [LHsRecUpdProj p]
olRecUpdFields = [LHsRecUpdProj GhcPs]
flds } ->
do { Extension
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.RebindableSyntax (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr TcRnMessage
TcRnNoRebindableSyntaxRecordDot
; let punnedFields :: [HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))]
punnedFields = [HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld | (L SrcSpanAnnA
_ HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld) <- [LHsRecUpdProj GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds, HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Bool
forall lhs rhs. HsFieldBind lhs rhs -> Bool
hfbPun HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs))
fld]
; punsEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedFieldPuns
; unless (null punnedFields || punsEnabled) $
addErr TcRnNoFieldPunsRecordDot
; (getField, fv_getField) <- lookupSyntaxName getFieldName
; (setField, fv_setField) <- lookupSyntaxName setFieldName
; (e, fv_e) <- rnExpr expr
; (us, fv_us) <- rnHsUpdProjs flds
; let upd_flds = OverloadedRecUpdFields
{ xOLRecUpdFields :: XLHsOLRecUpdLabels GhcRn
xOLRecUpdFields = XLHsOLRecUpdLabels GhcRn
NoExtField
noExtField
, olRecUpdFields :: [LHsRecUpdProj GhcRn]
olRecUpdFields = [LHsRecUpdProj GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
us }
; return ( mkExpandedExpr
(RecordUpd noExtField (L l e) upd_flds)
(mkRecordDotUpd getField setField (L l e) us)
, plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) }
rnExpr (ExprWithTySig XExprWithTySig GhcPs
_ LHsExpr GhcPs
expr LHsSigWcType (NoGhcTc GhcPs)
pty)
= do { (pty', fvTy) <- HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
ExprWithTySigCtx LHsSigWcType (NoGhcTc GhcPs)
LHsSigWcType GhcPs
pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
rnExpr (HsIf XIf GhcPs
_ LHsExpr GhcPs
p LHsExpr GhcPs
b1 LHsExpr GhcPs
b2) = LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnHsIf LHsExpr GhcPs
p LHsExpr GhcPs
b1 LHsExpr GhcPs
b2
rnExpr (HsMultiIf XMultiIf GhcPs
_ [LGRHS GhcPs (LHsExpr GhcPs)]
alts)
= do { (alts', fvs) <- (GenLocated
(Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> RnM
(GenLocated
(Anno (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars))
-> [GenLocated
(Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> RnM
([GenLocated
(Anno (GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(GRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
forall (f :: * -> *) a b.
Traversable f =>
(a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
mapFvRn (HsMatchContextRn
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars))
-> LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> RnM
(LGRHS GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)
forall (body :: * -> *).
AnnoBody body =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
IfAlt LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
rnLExpr) [LGRHS GhcPs (LHsExpr GhcPs)]
[GenLocated
(Anno (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts
; return (HsMultiIf noExtField alts', fvs) }
rnExpr (ArithSeq XArithSeq GhcPs
_ Maybe (SyntaxExpr GhcPs)
_ ArithSeqInfo GhcPs
seq)
= do { opt_OverloadedLists <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
; if opt_OverloadedLists
then do {
; (from_list_name, fvs') <- lookupSyntax fromListName
; return (ArithSeq noExtField (Just from_list_name) new_seq
, fvs `plusFV` fvs') }
else
return (ArithSeq noExtField Nothing new_seq, fvs) }
rnExpr (HsEmbTy XEmbTy GhcPs
_ LHsWcType (NoGhcTc GhcPs)
ty)
= do { (ty', fvs) <- HsDocContext
-> HsWildCardBndrs GhcPs (LHsType GhcPs)
-> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
HsTypeCtx LHsWcType (NoGhcTc GhcPs)
HsWildCardBndrs GhcPs (LHsType GhcPs)
ty
; checkTypeSyntaxExtension TypeKeywordSyntax
; return (HsEmbTy noExtField ty', fvs) }
rnExpr (HsQual XQual GhcPs
_ (L SrcSpanAnnC
ann [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ctxt) LHsExpr GhcPs
ty)
= do { (ctxt', fvs_ctxt) <- (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars))
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsExpr GhcRn)], [FreeVars])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
rnLExpr [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
ctxt
; (ty', fvs_ty) <- rnLExpr ty
; checkTypeSyntaxExtension ContextArrowSyntax
; return (HsQual noExtField (L ann ctxt') ty', plusFVs fvs_ctxt `plusFV` fvs_ty) }
rnExpr (HsForAll XForAll GhcPs
_ HsForAllTelescope GhcPs
tele LHsExpr GhcPs
expr)
= HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope HsDocContext
HsTypeCtx HsForAllTelescope GhcPs
tele ((HsForAllTelescope GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars))
-> (HsForAllTelescope GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsForAllTelescope GhcRn
tele' ->
do { (expr', fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; checkTypeSyntaxExtension ForallTelescopeSyntax
; return (HsForAll noExtField tele' expr', fvs) }
rnExpr (HsFunArr XFunArr GhcPs
_ HsArrowOf (LHsExpr GhcPs) GhcPs
mult LHsExpr GhcPs
arg LHsExpr GhcPs
res)
= do { (arg', fvs1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arg
; (mult', fvs2) <- rnHsArrowWith rnLExpr mult
; (res', fvs3) <- rnLExpr res
; checkTypeSyntaxExtension FunctionArrowSyntax
; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) }
rnExpr e :: HsExpr GhcPs
e@(HsStatic XStatic GhcPs
_ LHsExpr GhcPs
expr) = do
Extension
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.StaticPointers (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> TcRnMessage
TcRnIllegalStaticExpression HsExpr GhcPs
e
(expr',fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
stage <- getStage
case stage of
Splice SpliceType
_ -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ THError -> TcRnMessage
TcRnTHError (THError -> TcRnMessage) -> THError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> THError
IllegalStaticFormInSplice HsExpr GhcPs
e
ThStage
_ -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mod <- getModule
let fvExpr' = (Name -> Bool) -> FreeVars -> FreeVars
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod) FreeVars
fvExpr
return (HsStatic fvExpr' expr', fvExpr)
rnExpr (HsProc XProc GhcPs
x LPat GhcPs
pat LHsCmdTop GhcPs
body)
= TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. TcM a -> TcM a
newArrowScope (TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
HsMatchContextRn
-> LPat GhcPs
-> (LPat GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall a.
HsMatchContextRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat (HsArrowMatchContext -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsArrowMatchContext -> HsMatchContext fn
ArrowMatchCtxt HsArrowMatchContext
ProcExpr) LPat GhcPs
pat ((LPat GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars))
-> (LPat GhcRn -> TcM (HsExpr GhcRn, FreeVars))
-> TcM (HsExpr GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LPat GhcRn
pat' -> do
{ (body',fvBody) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
body
; return (HsProc x pat' body', fvBody) }
checkTypeSyntaxExtension :: TypeSyntax -> RnM ()
checkTypeSyntaxExtension :: TypeSyntax -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTypeSyntaxExtension TypeSyntax
syntax =
Extension
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM (TypeSyntax -> Extension
typeSyntaxExtension TypeSyntax
syntax) (IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TypeSyntax -> TcRnMessage
TcRnUnexpectedTypeSyntaxInTerms TypeSyntax
syntax)
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection :: HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnSection section :: HsExpr GhcPs
section@(SectionR XSectionR GhcPs
x LHsExpr GhcPs
op LHsExpr GhcPs
expr)
= do { (op', fvs_op) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
; let rn_section = XSectionR GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
XSectionR GhcRn
x XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
ds_section = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
rightSectionName [XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op',XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr']
; return ( mkExpandedExpr rn_section ds_section
, fvs_op `plusFV` fvs_expr) }
rnSection section :: HsExpr GhcPs
section@(SectionL XSectionL GhcPs
x LHsExpr GhcPs
expr LHsExpr GhcPs
op)
= do { (expr', fvs_expr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (op', fvs_op) <- rnLExpr op
; checkSectionPrec InfixL section op' expr'
; postfix_ops <- xoptM LangExt.PostfixOperators
; let rn_section = XSectionL GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
XSectionL GhcRn
x XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op'
ds_section
| Bool
postfix_ops = XApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr'
| Bool
otherwise = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
leftSectionName
[HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
expr']
; return ( mkExpandedExpr rn_section ds_section
, fvs_op `plusFV` fvs_expr) }
rnSection HsExpr GhcPs
other = String -> SDoc -> TcM (HsExpr GhcRn, FreeVars)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rnSection" (HsExpr GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcPs
other)
rnDotFieldOcc :: DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc :: DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc (DotFieldOcc XCDotFieldOcc GhcPs
x XRec GhcPs FieldLabelString
label) = XCDotFieldOcc GhcRn
-> XRec GhcRn FieldLabelString -> DotFieldOcc GhcRn
forall p.
XCDotFieldOcc p -> XRec p FieldLabelString -> DotFieldOcc p
DotFieldOcc XCDotFieldOcc GhcPs
XCDotFieldOcc GhcRn
x XRec GhcPs FieldLabelString
XRec GhcRn FieldLabelString
label
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings (FieldLabelStrings [XRec GhcPs (DotFieldOcc GhcPs)]
fls) = [XRec GhcRn (DotFieldOcc GhcRn)] -> FieldLabelStrings GhcRn
forall p. [XRec p (DotFieldOcc p)] -> FieldLabelStrings p
FieldLabelStrings ((GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn))
-> [GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)]
-> [GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ((DotFieldOcc GhcPs -> DotFieldOcc GhcRn)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)
forall a b.
(a -> b)
-> GenLocated (EpAnn NoEpAnns) a -> GenLocated (EpAnn NoEpAnns) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DotFieldOcc GhcPs -> DotFieldOcc GhcRn
rnDotFieldOcc) [XRec GhcPs (DotFieldOcc GhcPs)]
[GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcPs)]
fls)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [] = ([GenLocated (EpAnn NoEpAnns) (HsCmdTop GhcRn)], FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated (EpAnn NoEpAnns) (HsCmdTop GhcRn)], FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyFVs)
rnCmdArgs (LHsCmdTop GhcPs
arg:[LHsCmdTop GhcPs]
args)
= do { (arg',fvArg) <- LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop LHsCmdTop GhcPs
arg
; (args',fvArgs) <- rnCmdArgs args
; return (arg':args', fvArg `plusFV` fvArgs) }
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = (HsCmdTop GhcPs -> TcM (HsCmdTop GhcRn, FreeVars))
-> GenLocated (EpAnn NoEpAnns) (HsCmdTop GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated (EpAnn NoEpAnns) (HsCmdTop GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA HsCmdTop GhcPs -> TcM (HsCmdTop GhcRn, FreeVars)
rnCmdTop'
where
rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' :: HsCmdTop GhcPs -> TcM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' (HsCmdTop XCmdTop GhcPs
_ LHsCmd GhcPs
cmd)
= do { (cmd', fvCmd) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
cmd
; let cmd_names = [Name
arrAName, Name
composeAName, Name
firstAName] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
FreeVars -> [Name]
nameSetElemsStable (HsCmd GhcRn -> FreeVars
methodNamesCmd (GenLocated SrcSpanAnnA (HsCmd GhcRn) -> HsCmd GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsCmd GhcRn)
cmd'))
; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
fvCmd `plusFV` cmd_fvs) }
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = (HsCmd GhcPs -> TcM (HsCmd GhcRn, FreeVars))
-> GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsCmd GhcRn), FreeVars)
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA HsCmd GhcPs -> TcM (HsCmd GhcRn, FreeVars)
rnCmd
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd :: HsCmd GhcPs -> TcM (HsCmd GhcRn, FreeVars)
rnCmd (HsCmdArrApp XCmdArrApp GhcPs
_ LHsExpr GhcPs
arrow LHsExpr GhcPs
arg HsArrAppType
ho Bool
rtl)
= do { (arrow',fvArrow) <- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
select_arrow_scope (LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
arrow)
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdArrApp noExtField arrow' arg' ho rtl,
fvArrow `plusFV` fvArg) }
where
select_arrow_scope :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
select_arrow_scope IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc = case HsArrAppType
ho of
HsArrAppType
HsHigherOrderApp -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc
HsArrAppType
HsFirstOrderApp -> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
forall a. TcM a -> TcM a
escapeArrowScope IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
tc
rnCmd (HsCmdArrForm XCmdArrForm GhcPs
_ LHsExpr GhcPs
op LexicalFixity
f [LHsCmdTop GhcPs]
cmds)
= do { (op',fvOp) <- IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
forall a. TcM a -> TcM a
escapeArrowScope (LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
op)
; (cmds',fvCmds) <- rnCmdArgs cmds
; return ( HsCmdArrForm Nothing op' f cmds'
, fvOp `plusFV` fvCmds) }
rnCmd (HsCmdApp XCmdApp GhcPs
x LHsCmd GhcPs
fun LHsExpr GhcPs
arg)
= do { (fun',fvFun) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
fun
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
rnCmd (HsCmdLam XCmdLamCase GhcPs
x HsLamVariant
lam_variant MatchGroup GhcPs (LHsCmd GhcPs)
matches)
= do { let ctxt :: HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt = HsArrowMatchContext -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsArrowMatchContext -> HsMatchContext fn
ArrowMatchCtxt (HsArrowMatchContext
-> HsMatchContext (GenLocated SrcSpanAnnN Name))
-> HsArrowMatchContext
-> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall a b. (a -> b) -> a -> b
$ HsLamVariant -> HsArrowMatchContext
ArrowLamAlt HsLamVariant
lam_variant
; (new_matches, ms_fvs) <- HsMatchContextRn
-> (GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsCmd GhcRn), FreeVars))
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))
-> RnM
(MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)), FreeVars)
forall (body :: * -> *).
(Outputable (body GhcPs), AnnoBody body) =>
HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatchGroup HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctxt LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
GenLocated SrcSpanAnnA (HsCmd GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsCmd GhcRn), FreeVars)
rnLCmd MatchGroup GhcPs (LHsCmd GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))
matches
; return (HsCmdLam x lam_variant new_matches, ms_fvs) }
rnCmd (HsCmdPar XCmdPar GhcPs
_ LHsCmd GhcPs
e)
= do { (e', fvs_e) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
e
; return (HsCmdPar noExtField e', fvs_e) }
rnCmd (HsCmdCase XCmdCase GhcPs
_ LHsExpr GhcPs
expr MatchGroup GhcPs (LHsCmd GhcPs)
matches)
= do { (new_expr, e_fvs) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
; return (HsCmdCase noExtField new_expr new_matches
, e_fvs `plusFV` ms_fvs) }
rnCmd (HsCmdIf XCmdIf GhcPs
_ SyntaxExpr GhcPs
_ LHsExpr GhcPs
p LHsCmd GhcPs
b1 LHsCmd GhcPs
b2)
= do { (p', fvP) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
; mb_ite <- lookupIfThenElse
; let (ite, fvITE) = case 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)
; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
rnCmd (HsCmdLet XCmdLet GhcPs
_ HsLocalBinds GhcPs
binds LHsCmd GhcPs
cmd)
= HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> TcM (HsCmd GhcRn, FreeVars))
-> TcM (HsCmd GhcRn, FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn -> FreeVars -> TcM (HsCmd GhcRn, FreeVars))
-> TcM (HsCmd GhcRn, FreeVars))
-> (HsLocalBinds GhcRn -> FreeVars -> TcM (HsCmd GhcRn, FreeVars))
-> TcM (HsCmd GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsLocalBinds GhcRn
binds' FreeVars
_ -> do
{ (cmd',fvExpr) <- LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd LHsCmd GhcPs
cmd
; return (HsCmdLet noExtField binds' cmd', fvExpr) }
rnCmd (HsCmdDo XCmdDo GhcPs
_ (L SrcSpanAnnLW
l [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
stmts))
= do { ((stmts', _), fvs) <-
HsStmtContextRn
-> (HsCmd GhcPs -> TcM (HsCmd GhcRn, FreeVars))
-> [LStmt GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
-> ([Name] -> RnM ((), FreeVars))
-> RnM
(([LStmt GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))], ()),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsStmtContext fn
ArrowExpr HsCmd GhcPs -> TcM (HsCmd GhcRn, FreeVars)
rnCmd [LStmt GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))]
[GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs)))]
stmts (\ [Name]
_ -> ((), FreeVars) -> RnM ((), FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), FreeVars
emptyFVs))
; return ( HsCmdDo noExtField (L l stmts'), fvs ) }
type CmdNeeds = FreeVars
methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
methodNamesLCmd :: LHsCmd GhcRn -> FreeVars
methodNamesLCmd = HsCmd GhcRn -> FreeVars
methodNamesCmd (HsCmd GhcRn -> FreeVars)
-> (GenLocated SrcSpanAnnA (HsCmd GhcRn) -> HsCmd GhcRn)
-> GenLocated SrcSpanAnnA (HsCmd GhcRn)
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsCmd GhcRn) -> HsCmd GhcRn
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 SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts)) = [CmdLStmt GhcRn] -> FreeVars
methodNamesStmts [CmdLStmt GhcRn]
[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 (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 (HsCmdLam XCmdLamCase GhcRn
_ HsLamVariant
LamSingle MatchGroup GhcRn (LHsCmd GhcRn)
matches) = MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch MatchGroup GhcRn (LHsCmd GhcRn)
matches
methodNamesCmd (HsCmdLam XCmdLamCase GhcRn
_ HsLamVariant
_ 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 SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
ms })
= [FreeVars] -> FreeVars
plusFVs ((GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars)
-> [GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
-> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
SrcSpanAnnA (Match GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
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 (LHsCmd GhcRn)
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 ((LocatedAn
NoEpAnns (GRHS GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars)
-> [LocatedAn
NoEpAnns (GRHS GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
-> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> FreeVars
LocatedAn
NoEpAnns (GRHS GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
methodNamesGRHS [LGRHS GhcRn (LHsCmd GhcRn)]
[LocatedAn
NoEpAnns (GRHS GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
grhss)
methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesGRHS (L EpAnn NoEpAnns
_ (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 ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars)
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
-> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map CmdLStmt GhcRn -> FreeVars
GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
methodNamesLStmt [CmdLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts)
methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesLStmt :: CmdLStmt GhcRn -> FreeVars
methodNamesLStmt = StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
-> FreeVars
methodNamesStmt (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
-> FreeVars)
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> FreeVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn))
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 SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsCmd GhcRn)))]
stmts }) =
[CmdLStmt GhcRn] -> FreeVars
methodNamesStmts [CmdLStmt GhcRn]
[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 (XStmtLR ApplicativeStmt{}) = FreeVars
emptyFVs
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq (From LHsExpr GhcPs
expr)
= do { (expr', fvExpr) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr
; return (From expr', fvExpr) }
rnArithSeq (FromThen LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
= do { (expr1', fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2)
= do { (expr1', fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromThenTo LHsExpr GhcPs
expr1 LHsExpr GhcPs
expr2 LHsExpr GhcPs
expr3)
= do { (expr1', fvExpr1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; (expr3', fvExpr3) <- rnLExpr expr3
; return (FromThenTo expr1' expr2' expr3',
plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
type AnnoBody body
= ( Outputable (body GhcPs)
)
rnStmts :: AnnoBody body
=> HsStmtContextRn
-> (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 =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
= do { ((stmts', thing), fvs) <- HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (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 HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
stmts [Name] -> RnM (thing, FreeVars)
thing_inside
; return ((map fst stmts', thing), fvs) }
postProcessStmtsForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo :: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo HsDoFlavour
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts
= do {
ado_is_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ApplicativeDo
; let is_do_expr | DoExpr{} <- HsDoFlavour
ctxt = Bool
True
| Bool
otherwise = Bool
False
; in_th_bracket <- isBrackStage <$> getStage
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
; rearrangeForApplicativeDo ctxt stmts }
else noPostProcessStmts (HsDoStmt ctxt) stmts }
noPostProcessStmts
:: HsStmtContextRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts :: forall (body :: * -> *).
HsStmtContextRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts HsStmtContextRn
_ [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
stmts = ([GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))
forall a b. (a, b) -> a
fst [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
stmts, FreeVars
emptyNameSet)
rnStmtsWithFreeVars :: AnnoBody body
=> HsStmtContextRn
-> ((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 =>
HsStmtContextRn
-> (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 HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
_ [] [Name] -> RnM (thing, FreeVars)
thing_inside
= do { HsStmtContextRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContextRn
ctxt
; (thing, fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside []
; return (([], thing), fvs) }
rnStmtsWithFreeVars mDoExpr :: HsStmtContextRn
mDoExpr@(HsDoStmt MDoExpr{}) body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody ([LStmt GhcPs (LocatedA (body GhcPs))]
-> Maybe
(NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))))
[GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
-> Maybe
(NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty -> Just NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
stmts) [Name] -> RnM (thing, FreeVars)
thing_inside
=
do { ((stmts1, (stmts2, thing)), fvs)
<- HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (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 HsStmtContextRn
mDoExpr body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
-> StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
forall a b. (a -> b) -> a -> b
$ AnnList (EpToken "rec")
-> LocatedLW [LStmt GhcPs (LocatedA (body GhcPs))]
-> StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
forall (idL :: Pass) bodyR.
(Anno
[GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
~ SrcSpanAnnLW) =>
AnnList (EpToken "rec")
-> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt AnnList (EpToken "rec")
forall a. NoAnn a => a
noAnn ([GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA (NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
forall a. NonEmpty a -> [a]
NE.init NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
stmts))) (([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars))
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
_ ->
do { last_stmt' <- HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContextRn
mDoExpr (NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
-> GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
forall a. NonEmpty a -> a
NE.last NonEmpty
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
stmts)
; rnStmt mDoExpr rnBody last_stmt' thing_inside }
; return (((stmts1 ++ stmts2), thing), fvs) }
rnStmtsWithFreeVars HsStmtContextRn
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
| [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LStmt GhcPs (LocatedA (body GhcPs))]
[GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
lstmts
= SrcSpanAnnA
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall a b. (a -> b) -> a -> b
$
do { lstmt' <- HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContextRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt
; rnStmt ctxt rnBody lstmt' thing_inside }
| Bool
otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
<- SrcSpanAnnA
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall a b. (a -> b) -> a -> b
$
do { HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContextRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt
; HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (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 HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody LStmt GhcPs (LocatedA (body GhcPs))
lstmt (([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars))
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing)),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs1 ->
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (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 HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [LStmt GhcPs (LocatedA (body GhcPs))]
lstmts (([Name] -> RnM (thing, FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> ([Name] -> RnM (thing, FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs2 ->
[Name] -> RnM (thing, FreeVars)
thing_inside ([Name]
bndrs1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
rnStmt :: AnnoBody body
=> HsStmtContextRn
-> (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 =>
HsStmtContextRn
-> (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 HsStmtContextRn
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', fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (ret_op, fvs1) <- if isMonadCompContext ctxt
then lookupStmtName ctxt returnMName
else return (noSyntaxExpr, emptyFVs)
; (thing, fvs3) <- thing_inside []
; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)]
, thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
rnStmt HsStmtContextRn
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', fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName
; (guard_op, fvs2) <- if isComprehensionContext ctxt
then lookupStmtName ctxt guardMName
else return (noSyntaxExpr, emptyFVs)
; (thing, fvs3) <- thing_inside []
; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)]
, thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt HsStmtContextRn
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', fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
; rnPat (StmtCtxt ctxt) pat $ \ LPat GhcRn
pat' -> do
{ (thing, fvs2) <- [Name] -> RnM (thing, FreeVars)
thing_inside (CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat')
; (fail_op, fvs3) <- monadFailOp pat' ctxt
; let xbsrn = XBindStmtRn { xbsrn_bindOp :: SyntaxExpr GhcRn
xbsrn_bindOp = SyntaxExpr GhcRn
SyntaxExprRn
bind_op, xbsrn_failOp :: Maybe (SyntaxExpr GhcRn)
xbsrn_failOp = Maybe (SyntaxExpr GhcRn)
Maybe SyntaxExprRn
fail_op }
; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
rnStmt HsStmtContextRn
_ 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
= HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall result.
HsLocalBinds GhcPs
-> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen HsLocalBinds GhcPs
binds ((HsLocalBinds GhcRn
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> (HsLocalBinds GhcRn
-> FreeVars
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([(XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
thing),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \HsLocalBinds GhcRn
binds' FreeVars
bind_fvs -> do
{ (thing, fvs) <- [Name] -> RnM (thing, FreeVars)
thing_inside (CollectFlag GhcRn -> HsLocalBinds GhcRn -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
CollectPass (GhcPass idL) =>
CollectFlag (GhcPass idL)
-> HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsLocalBinds GhcRn
binds')
; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)
, fvs) }
rnStmt HsStmtContextRn
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 SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
rec_stmts })) [Name] -> RnM (thing, FreeVars)
thing_inside
= do { (return_op, fvs1) <- HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContextRn
ctxt Name
returnMName
; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName
; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName
; let empty_rec_stmt = (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
forall bodyR.
(Anno
[GenLocated
(Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)]
~ SrcSpanAnnLW) =>
StmtLR GhcRn GhcRn bodyR
forall {body :: * -> *}. StmtLR GhcRn GhcRn (LocatedA (body GhcRn))
emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))
{ recS_ret_fn = return_op
, recS_mfix_fn = mfix_op
, recS_bind_fn = bind_op }
; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ [(FreeVars, FreeVars, FreeVars,
XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
segs -> do
{ let bndrs :: [Name]
bndrs = FreeVars -> [Name]
nameSetElemsStable (FreeVars -> [Name]) -> FreeVars -> [Name]
forall a b. (a -> b) -> a -> b
$
((FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))
-> FreeVars -> FreeVars)
-> FreeVars
-> [(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
-> FreeVars
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FreeVars -> FreeVars -> FreeVars
unionNameSet (FreeVars -> FreeVars -> FreeVars)
-> ((FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))
-> FreeVars)
-> (FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))
-> FreeVars
-> FreeVars
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
[(FreeVars, FreeVars, FreeVars,
XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
segs
; (thing, fvs_later) <- [Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs
; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv
; let
(rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive)
; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
, fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
rnStmt HsStmtContextRn
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 { (mzip_op, fvs1) <- HsStmtContextRn -> Name -> TcM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContextRn
ctxt Name
mzipName
; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt HsStmtContextRn
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 {
(using', fvs1) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
using
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ [Name]
bndrs ->
do { (by', fvs_by) <- (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> RnM (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)
forall a b.
(a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsExpr GhcRn), FreeVars)
rnLExpr Maybe (LHsExpr GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = FreeVars
fvs_by FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_thing
used_bndrs = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
; return ((by', used_bndrs, thing), fvs) }
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
; (fmap_op, fvs5) <- case form of
TransForm
ThenForm -> (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p)
noExpr, FreeVars
emptyFVs)
TransForm
_ -> HsStmtContextRn -> Name -> TcM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContextRn
ctxt Name
fmapName
; let 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]
used_bndrs [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
used_bndrs
; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
; return (([(L loc (TransStmt { trS_ext = noExtField
, trS_stmts = stmts', trS_bndrs = bndr_map
, trS_by = by', trS_using = using', trS_form = form
, trS_ret = return_op, trS_bind = bind_op
, trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
rnParallelStmts :: forall thing. HsStmtContextRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts :: forall thing.
HsStmtContextRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts HsStmtContextRn
ctxt SyntaxExpr GhcRn
return_op [ParStmtBlock GhcPs GhcPs]
segs [Name] -> RnM (thing, FreeVars)
thing_inside
= do { orig_lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
; rn_segs orig_lcl_env [] segs }
where
rn_segs :: LocalRdrEnv
-> [Name] -> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs :: LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs LocalRdrEnv
_ [Name]
bndrs_so_far []
= do { let ([Name]
bndrs', [NonEmpty Name]
dups) = (Name -> OccName) -> [Name] -> ([Name], [NonEmpty Name])
forall b a. Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])
removeDupsOn Name -> OccName
nameOccName [Name]
bndrs_so_far
; (NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [NonEmpty Name] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr [NonEmpty Name]
dups
; (thing, fvs) <- [Name] -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs' ([Name] -> RnM (thing, FreeVars)
thing_inside [Name]
bndrs')
; return (([], thing), 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 { ((stmts', (used_bndrs, segs', thing)), fvs)
<- HsStmtContextRn
-> (HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars))
-> [LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))],
([Name], [ParStmtBlock GhcRn GhcRn], thing)),
FreeVars)
forall (body :: * -> *) thing.
AnnoBody body =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts HsStmtContextRn
ctxt HsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnExpr [ExprLStmt GhcPs]
[LStmt GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
stmts (([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))],
([Name], [ParStmtBlock GhcRn GhcRn], thing)),
FreeVars))
-> ([Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))],
([Name], [ParStmtBlock GhcRn GhcRn], thing)),
FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
bndrs ->
LocalRdrEnv
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
env (IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(([Name], [ParStmtBlock GhcRn GhcRn], thing), FreeVars)
forall a b. (a -> b) -> a -> b
$ do
{ ((segs', thing), fvs) <- LocalRdrEnv
-> [Name]
-> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs LocalRdrEnv
env ([Name]
bndrs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
bndrs_so_far) [ParStmtBlock GhcPs GhcPs]
segs
; let used_bndrs = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> FreeVars -> Bool
`elemNameSet` FreeVars
fvs) [Name]
bndrs
; return ((used_bndrs, segs', thing), fvs) }
; let seg' = XParStmtBlock GhcRn GhcRn
-> [ExprLStmt GhcRn]
-> [IdP GhcRn]
-> SyntaxExpr GhcRn
-> ParStmtBlock GhcRn GhcRn
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcPs GhcPs
XParStmtBlock GhcRn GhcRn
x [ExprLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
stmts' [IdP GhcRn]
[Name]
used_bndrs SyntaxExpr GhcRn
return_op
; return ((seg':segs', thing), fvs) }
dupErr :: NonEmpty Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
dupErr NonEmpty Name
vs = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ Name -> TcRnMessage
TcRnListComprehensionDuplicateBinding (NonEmpty Name -> Name
forall a. NonEmpty a -> a
NE.head NonEmpty Name
vs)
lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName HsStmtContextRn
ctxt Name
n
= case HsStmtContext (GenLocated SrcSpanAnnN Name) -> Maybe ModuleName
forall fn. HsStmtContext fn -> Maybe ModuleName
qualifiedDoModuleName_maybe HsStmtContextRn
HsStmtContext (GenLocated SrcSpanAnnN Name)
ctxt of
Maybe ModuleName
Nothing -> HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContextRn
ctxt Name
n
Just ModuleName
modName ->
(Name -> SyntaxExprRn)
-> (Name, FreeVars) -> (SyntaxExprRn, FreeVars)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Name -> SyntaxExprRn
mkRnSyntaxExpr ((Name, FreeVars) -> (SyntaxExprRn, FreeVars))
-> RnM (Name, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (SyntaxExprRn, FreeVars)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ModuleName -> RnM (Name, FreeVars)
lookupNameWithQualifier Name
n ModuleName
modName
lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName HsStmtContextRn
ctxt Name
n
| HsStmtContextRn -> Bool
rebindableContext HsStmtContextRn
ctxt
= Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupSyntax Name
n
| Bool
otherwise
= (SyntaxExprRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (SyntaxExprRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
n, FreeVars
emptyFVs)
lookupStmtNamePoly :: HsStmtContextRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly :: HsStmtContextRn -> Name -> TcM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly HsStmtContextRn
ctxt Name
name
| HsStmtContextRn -> Bool
rebindableContext HsStmtContextRn
ctxt
= do { rebindable_on <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RebindableSyntax
; if rebindable_on
then do { fm <- lookupOccRn (nameRdrName name)
; return (HsVar noExtField (noLocA fm), unitFV fm) }
else not_rebindable }
| Bool
otherwise
= TcM (HsExpr GhcRn, FreeVars)
not_rebindable
where
not_rebindable :: TcM (HsExpr GhcRn, FreeVars)
not_rebindable = (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcRn -> XRec GhcRn (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (Name -> GenLocated SrcSpanAnnN Name
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA Name
name), FreeVars
emptyFVs)
rebindableContext :: HsStmtContextRn -> Bool
rebindableContext :: HsStmtContextRn -> Bool
rebindableContext HsStmtContextRn
ctxt = case HsStmtContextRn
ctxt of
HsDoStmt HsDoFlavour
flavour -> HsDoFlavour -> Bool
rebindableDoStmtContext HsDoFlavour
flavour
HsStmtContextRn
ArrowExpr -> Bool
False
PatGuard {} -> Bool
False
ParStmtCtxt HsStmtContextRn
c -> HsStmtContextRn -> Bool
rebindableContext HsStmtContextRn
c
TransStmtCtxt HsStmtContextRn
c -> HsStmtContextRn -> Bool
rebindableContext HsStmtContextRn
c
rebindableDoStmtContext :: HsDoFlavour -> Bool
rebindableDoStmtContext :: HsDoFlavour -> Bool
rebindableDoStmtContext HsDoFlavour
flavour = case HsDoFlavour
flavour of
HsDoFlavour
ListComp -> Bool
False
DoExpr Maybe ModuleName
m -> Maybe ModuleName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ModuleName
m
MDoExpr Maybe ModuleName
m -> Maybe ModuleName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ModuleName
m
HsDoFlavour
MonadComp -> Bool
True
HsDoFlavour
GhciStmtCtxt -> Bool
True
type FwdRefs = NameSet
type Segment stmts = (Defs,
Uses,
FwdRefs,
stmts)
rnRecStmtsAndThen :: AnnoBody body
=> HsStmtContextRn
-> (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 =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen HsStmtContextRn
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 {
fix_env <- [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv ([LStmt GhcPs (LocatedA (body GhcPs))] -> [LFixitySig GhcPs]
forall body. [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmt GhcPs (LocatedA (body GhcPs))]
s)
; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
; let bound_names = CollectFlag GhcRn
-> [LStmtLR GhcRn GhcPs (LocatedA (body GhcPs))] -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
(IsPass idL, IsPass idR, CollectPass (GhcPass idL)) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))
forall a b. (a, b) -> a
fst [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv)
rec_uses = [LStmtLR GhcRn GhcPs (LocatedA (body GhcPs))]
-> [(SrcSpan, [ImplicitFieldBinders])]
forall (idR :: Pass) (body :: * -> *).
IsPass idR =>
[LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
-> [(SrcSpan, [ImplicitFieldBinders])]
lStmtsImplicits (((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))
forall a b. (a, b) -> a
fst [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
new_lhs_and_fv)
implicit_uses = [Name] -> FreeVars
mkNameSet ([Name] -> FreeVars) -> [Name] -> FreeVars
forall a b. (a -> b) -> a -> b
$ ((SrcSpan, [ImplicitFieldBinders]) -> [Name])
-> [(SrcSpan, [ImplicitFieldBinders])] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ImplicitFieldBinders -> [Name])
-> [ImplicitFieldBinders] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ImplicitFieldBinders -> [Name]
implFlBndr_binders ([ImplicitFieldBinders] -> [Name])
-> ((SrcSpan, [ImplicitFieldBinders]) -> [ImplicitFieldBinders])
-> (SrcSpan, [ImplicitFieldBinders])
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan, [ImplicitFieldBinders]) -> [ImplicitFieldBinders]
forall a b. (a, b) -> b
snd) ([(SrcSpan, [ImplicitFieldBinders])] -> [Name])
-> [(SrcSpan, [ImplicitFieldBinders])] -> [Name]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, [ImplicitFieldBinders])]
rec_uses
; bindLocalNamesFV bound_names $
addLocalFixities fix_env bound_names $ do
{ segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv
; (res, fvs) <- cont segs
; mapM_ (\(SrcSpan
loc, [ImplicitFieldBinders]
ns) -> SrcSpan
-> FreeVars
-> Maybe [ImplicitFieldBinders]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkUnusedRecordWildcard SrcSpan
loc FreeVars
fvs ([ImplicitFieldBinders] -> Maybe [ImplicitFieldBinders]
forall a. a -> Maybe a
Just [ImplicitFieldBinders]
ns))
rec_uses
; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
; return (res, fvs) }}
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities :: forall body. [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities [LStmtLR GhcPs GhcPs body]
l =
(GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)])
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> [GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)]
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)))) ->
(GenLocated SrcSpanAnnA (Sig GhcPs)
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)])
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)) -> (SrcSpanAnnA
-> FixitySig GhcPs -> GenLocated SrcSpanAnnA (FixitySig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FixitySig GhcPs
s) GenLocated SrcSpanAnnA (FixitySig GhcPs)
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
-> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
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]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR GhcPs GhcPs body)
_ -> [GenLocated SrcSpanAnnA (FixitySig GhcPs)]
acc) [] [LStmtLR GhcPs GhcPs body]
[GenLocated
(Anno (StmtLR GhcPs GhcPs body)) (StmtLR 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))
= [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpanAnnA
-> StmtLR GhcRn GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XBodyStmt GhcRn GhcPs (LocatedA (body GhcPs))
-> LocatedA (body GhcPs)
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcRn GhcPs (LocatedA (body GhcPs))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt XBodyStmt GhcRn GhcPs (LocatedA (body GhcPs))
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))
= [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(SrcSpanAnnA
-> StmtLR GhcRn GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLastStmt GhcRn GhcPs (LocatedA (body GhcPs))
-> LocatedA (body GhcPs)
-> Maybe Bool
-> SyntaxExpr GhcPs
-> StmtLR GhcRn GhcPs (LocatedA (body GhcPs))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcPs (LocatedA (body GhcPs))
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
(pat', fv_pat) <- NameMaker -> LPat GhcPs -> RnM (LPat GhcRn, FreeVars)
rnBindPat (MiniFixityEnv -> NameMaker
localRecNameMaker MiniFixityEnv
fix_env) LPat GhcPs
pat
return [(L loc (BindStmt noAnn pat' body), fv_pat)]
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ binds :: HsLocalBinds GhcPs
binds@(HsIPBinds {})))
= TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. TcRnMessage -> TcRn a
failWith (Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
-> TcRnMessage
badIpBinds (HsLocalBinds GhcPs
-> Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
forall a b. a -> Either a b
Left 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 (_bound_names, binds') <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
fix_env HsValBindsLR GhcPs GhcPs
binds
return [(L loc (LetStmt noAnn (HsValBinds x binds')),
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 SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
stmts }))
= MiniFixityEnv
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(XRec GhcRn (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
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))]
[GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
stmts
rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs (LocatedA (body GhcPs))
stmt@(L SrcSpanAnnA
_ (ParStmt {}))
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt" (GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
stmt)
rn_rec_stmt_lhs MiniFixityEnv
_ stmt :: LStmt GhcPs (LocatedA (body GhcPs))
stmt@(L SrcSpanAnnA
_ (TransStmt {}))
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt" (GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
stmt)
rn_rec_stmt_lhs MiniFixityEnv
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)))
= String
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall a. HasCallStack => 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 { ls <- (GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)])
-> [GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (MiniFixityEnv
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(XRec GhcRn (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
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))]
[GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]
stmts
; let boundNames = CollectFlag GhcRn
-> [XRec GhcRn (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))]
-> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
(IsPass idL, IsPass idR, CollectPass (GhcPass idL)) =>
CollectFlag (GhcPass idL)
-> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))))
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs)))
forall a b. (a, b) -> a
fst [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
ls)
; checkDupNames boundNames
; return ls }
rn_rec_stmt :: AnnoBody body =>
HsStmtContextRn
-> (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 =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt HsStmtContextRn
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', fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
L loc (LastStmt noExtField (L lb body') noret ret_op))] }
rn_rec_stmt HsStmtContextRn
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', fvs) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] }
rn_rec_stmt HsStmtContextRn
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', fv_expr) <- body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody body GhcPs
body
; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
; (fail_op, fvs2) <- getMonadFailOp ctxt
; let bndrs = [Name] -> FreeVars
mkNameSet (CollectFlag GhcRn -> LPat GhcRn -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders LPat GhcRn
pat')
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_bindOp :: SyntaxExpr GhcRn
xbsrn_bindOp = SyntaxExpr GhcRn
SyntaxExprRn
bind_op, xbsrn_failOp :: Maybe (SyntaxExpr GhcRn)
xbsrn_failOp = Maybe (SyntaxExpr GhcRn)
Maybe SyntaxExprRn
fail_op }
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt xbsrn pat' (L lb body')))] }
rn_rec_stmt HsStmtContextRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ binds :: HsLocalBindsLR GhcRn GhcPs
binds@(HsIPBinds {})), FreeVars
_)
= TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall a. TcRnMessage -> TcRn a
failWith (Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
-> TcRnMessage
badIpBinds (HsLocalBindsLR GhcRn GhcPs
-> Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
forall a b. b -> Either a b
Right HsLocalBindsLR GhcRn GhcPs
binds))
rn_rec_stmt HsStmtContextRn
_ 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 { (binds', du_binds) <- FreeVars
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> FreeVars
mkNameSet [Name]
all_bndrs) HsValBindsLR GhcRn GhcPs
binds'
; let fvs = DefUses -> FreeVars
allUses DefUses
du_binds
; return [(duDefs du_binds, fvs, emptyNameSet,
L loc (LetStmt noAnn (HsValBinds x binds')))] }
rn_rec_stmt HsStmtContextRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (RecStmt {}), FreeVars
_)
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: RecStmt" ((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
stmt)
rn_rec_stmt HsStmtContextRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (ParStmt {}), FreeVars
_)
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: ParStmt" ((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
stmt)
rn_rec_stmt HsStmtContextRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ stmt :: (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
stmt@(L SrcSpanAnnA
_ (TransStmt {}), FreeVars
_)
= String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rn_rec_stmt: TransStmt" ((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
stmt)
rn_rec_stmt HsStmtContextRn
_ body GhcPs -> RnM (body GhcRn, FreeVars)
_ [Name]
_ (L SrcSpanAnnA
_ (LetStmt XLetStmt GhcRn GhcPs (LocatedA (body GhcPs))
_ (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcPs
_)), FreeVars
_)
= String
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall a. HasCallStack => String -> a
panic String
"rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmts :: AnnoBody body
=> HsStmtContextRn
-> (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 =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmts HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
bndrs [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
stmts
= do { segs_s <- ((GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))])
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[[Segment
(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(FreeVars, FreeVars, FreeVars,
XRec GhcRn (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))))]
forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt HsStmtContextRn
ctxt body GhcPs -> RnM (body GhcRn, FreeVars)
rnBody [Name]
bndrs) [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))),
FreeVars)]
stmts
; return (concat segs_s) }
segmentRecStmts :: SrcSpan -> HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> (FreeVars, Bool)
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts :: forall (body :: * -> *).
SrcSpan
-> HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> (FreeVars, Bool)
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts SrcSpan
loc HsStmtContextRn
ctxt Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
segs (FreeVars
fvs_later, Bool
might_be_more_fvs_later)
| [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
[Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
segs
= ([], FreeVars
final_fv_uses)
| HsDoStmt (MDoExpr Maybe ModuleName
_) <- HsStmtContextRn
ctxt
= Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
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
= ([ SrcSpanAnnA
-> Stmt GhcRn (LocatedA (body GhcRn))
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (Stmt GhcRn (LocatedA (body GhcRn))
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))
-> Stmt GhcRn (LocatedA (body GhcRn))
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
forall a b. (a -> b) -> a -> b
$
Stmt GhcRn (LocatedA (body GhcRn))
empty_rec_stmt { recS_stmts = noLocA ss
, recS_later_ids = nameSetElemsStable final_fvs_later
, recS_rec_ids = nameSetElemsStable
(defs `intersectNameSet` uses) }]
, FreeVars
uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
final_fv_uses)
where
(FreeVars
final_fv_uses, FreeVars
final_fvs_later)
| Bool
might_be_more_fvs_later
= (FreeVars
defs, FreeVars
defs)
| Bool
otherwise
= ( FreeVars
uses FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_later
, FreeVars
defs FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
fvs_later )
([FreeVars]
defs_s, [FreeVars]
uses_s, [FreeVars]
_, [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
ss) = [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
-> ([FreeVars], [FreeVars], [FreeVars],
[GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
[Segment
(GenLocated SrcSpanAnnA (Stmt 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 = [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
-> [Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
forall a. [Segment a] -> [Segment a]
addFwdRefs [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
[Segment
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn))))]
segs
grouped_segs :: [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
grouped_segs = HsStmtContextRn
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
forall body.
HsStmtContextRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContextRn
ctxt [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
[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
= ([Segment a], FreeVars) -> [Segment a]
forall a b. (a, b) -> a
fst ((Segment a -> ([Segment a], FreeVars) -> ([Segment a], FreeVars))
-> ([Segment a], FreeVars)
-> [Segment a]
-> ([Segment a], FreeVars)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Segment a -> ([Segment a], FreeVars) -> ([Segment a], FreeVars)
forall {d}.
(FreeVars, FreeVars, FreeVars, d)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
mk_seg ([], FreeVars
emptyNameSet) [Segment a]
segs)
where
mk_seg :: (FreeVars, FreeVars, FreeVars, d)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
-> ([(FreeVars, FreeVars, FreeVars, d)], FreeVars)
mk_seg (FreeVars
defs, FreeVars
uses, FreeVars
fwds, d
stmts) ([(FreeVars, FreeVars, FreeVars, d)]
segs, FreeVars
later_defs)
= ((FreeVars, FreeVars, FreeVars, d)
new_seg (FreeVars, FreeVars, FreeVars, d)
-> [(FreeVars, FreeVars, FreeVars, d)]
-> [(FreeVars, FreeVars, FreeVars, d)]
forall a. a -> [a] -> [a]
: [(FreeVars, FreeVars, FreeVars, d)]
segs, FreeVars
all_defs)
where
new_seg :: (FreeVars, FreeVars, FreeVars, d)
new_seg = (FreeVars
defs, FreeVars
uses, FreeVars
new_fwds, d
stmts)
all_defs :: FreeVars
all_defs = FreeVars
later_defs FreeVars -> FreeVars -> FreeVars
`unionNameSet` FreeVars
defs
new_fwds :: FreeVars
new_fwds = FreeVars
fwds FreeVars -> FreeVars -> FreeVars
`unionNameSet` (FreeVars
uses FreeVars -> FreeVars -> FreeVars
`intersectNameSet` FreeVars
later_defs)
glomSegments :: HsStmtContextRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
glomSegments :: forall body.
HsStmtContextRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContextRn
_ [] = []
glomSegments HsStmtContextRn
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) Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
-> [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
-> [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
forall a. a -> [a] -> [a]
: [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
others
where
segs' :: [(FreeVars, FreeVars, FreeVars, [LStmt GhcRn body])]
segs' = HsStmtContextRn
-> [Segment (LStmt GhcRn body)]
-> [(FreeVars, FreeVars, FreeVars, [LStmt GhcRn body])]
forall body.
HsStmtContextRn
-> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]]
glomSegments HsStmtContextRn
ctxt [Segment (LStmt GhcRn body)]
segs
([Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
extras, [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
others) = FreeVars
-> [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
-> ([Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]],
[Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]])
forall a. FreeVars -> [Segment a] -> ([Segment a], [Segment a])
grab FreeVars
uses [(FreeVars, FreeVars, FreeVars, [LStmt GhcRn body])]
[Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
segs'
([FreeVars]
ds, [FreeVars]
us, [FreeVars]
fs, [[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
ss) = [Segment
[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
-> ([FreeVars], [FreeVars], [FreeVars],
[[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [Segment
[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
GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)
stmt GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)
-> [GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
-> [GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
forall a. a -> [a] -> [a]
: [[GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]]
-> [GenLocated
(Anno (StmtLR GhcRn GhcRn body)) (StmtLR GhcRn GhcRn body)]
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
= ([Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
yeses, [Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
noes)
where
([Segment a]
noes, [Segment a]
yeses) = (Segment a -> Bool) -> [Segment a] -> ([Segment a], [Segment a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Segment a -> Bool
not_needed ([Segment a] -> [Segment a]
forall a. [a] -> [a]
reverse [Segment a]
dus)
not_needed :: Segment a -> Bool
not_needed (FreeVars
defs,FreeVars
_,FreeVars
_,a
_) = 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
= Bool
-> ([GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))],
FreeVars)
-> ([GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))],
FreeVars)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LStmt GhcRn (LocatedA (body GhcRn))]
[GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
ss))
(GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
new_stmt GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
-> [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
-> [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
forall a. a -> [a] -> [a]
: [LStmt GhcRn (LocatedA (body GhcRn))]
[GenLocated SrcSpanAnnA (Stmt 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) = Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
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 = [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
forall a. HasCallStack => [a] -> a
head [LStmt GhcRn (LocatedA (body GhcRn))]
[GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
ss
| Bool
otherwise = SrcSpanAnnA
-> Stmt GhcRn (LocatedA (body GhcRn))
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
-> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc ([GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
-> GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))
forall a. HasCallStack => [a] -> a
head [LStmt GhcRn (LocatedA (body GhcRn))]
[GenLocated SrcSpanAnnA (Stmt 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 = noLocA ss
, recS_later_ids = nameSetElemsStable used_later
, recS_rec_ids = nameSetElemsStable fwds }
non_rec :: Bool
non_rec = [GenLocated SrcSpanAnnA (Stmt GhcRn (LocatedA (body GhcRn)))]
-> Bool
forall a. [a] -> Bool
isSingleton [LStmt GhcRn (LocatedA (body GhcRn))]
[GenLocated SrcSpanAnnA (Stmt 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
forall doc. IsLine doc => [doc] -> doc
hcat
[String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MonadNames { return_name = "
,Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
return_name
,String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", pure_name = "
,Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
pure_name
,String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}"
]
rearrangeForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo :: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo HsDoFlavour
_ [] = ([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsDoFlavour
ctxt [(ExprLStmt GhcRn
one,FreeVars
_)] = do
(return_name, _) <- HsStmtContext (ZonkAny 2) -> Name -> RnM (Name, FreeVars)
forall fn. HsStmtContext fn -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName (HsDoFlavour -> HsStmtContext (ZonkAny 2)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt) Name
returnMName
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let monad_names = MonadNames { return_name :: Name
return_name = Name
return_name
, pure_name :: Name
pure_name = Name
pure_name }
return $ case needJoin monad_names [one] (Just pure_name) of
(Bool
False, [ExprLStmt GhcRn]
one') -> ([ExprLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
one', FreeVars
emptyNameSet)
(Bool
True, [ExprLStmt GhcRn]
_) -> ([ExprLStmt GhcRn
GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
one], FreeVars
emptyNameSet)
rearrangeForApplicativeDo HsDoFlavour
ctxt [(ExprLStmt GhcRn, FreeVars)]
stmts0 = do
optimal_ado <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_OptimalApplicativeDo
let stmt_tree | Bool
optimal_ado = [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
| Bool
otherwise = [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
traceRn "rearrangeForADo" (ppr stmt_tree)
(return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let monad_names = MonadNames { return_name :: Name
return_name = Name
return_name
, pure_name :: Name
pure_name = Name
pure_name }
stmtTreeToStmts monad_names ctxt stmt_tree [last] 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)) = [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)],
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars))
forall {a}. [a] -> ([a], a)
findLast [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts0
findLast :: [a] -> ([a], a)
findLast [] = String -> ([a], a)
forall a. HasCallStack => String -> a
error String
"findLast"
findLast [a
last] = ([],a
last)
findLast (a
x:[a]
xs) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest,a
last) where ([a]
rest,a
last) = [a] -> ([a], a)
findLast [a]
xs
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
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StmtTreeOne" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)
ppr (StmtTreeBind StmtTree a
x StmtTree a
y) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StmtTreeBind")
Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [StmtTree a -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtTree a
x, StmtTree a -> SDoc
forall a. Outputable a => a -> SDoc
ppr StmtTree a
y]))
ppr (StmtTreeApplicative [StmtTree a]
xs) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StmtTreeApplicative")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((StmtTree a -> SDoc) -> [StmtTree a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map StmtTree a -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StmtTree a]
xs)))
flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree :: forall a. StmtTree a -> [a]
flattenStmtTree StmtTree a
t = StmtTree a -> [a] -> [a]
forall {a}. StmtTree a -> [a] -> [a]
go StmtTree a
t []
where
go :: StmtTree a -> [a] -> [a]
go (StmtTreeOne a
a) [a]
as = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
go (StmtTreeBind StmtTree a
l StmtTree a
r) [a]
as = StmtTree a -> [a] -> [a]
go StmtTree a
l (StmtTree a -> [a] -> [a]
go StmtTree a
r [a]
as)
go (StmtTreeApplicative [StmtTree a]
ts) [a]
as = (StmtTree a -> [a] -> [a]) -> [a] -> [StmtTree a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
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] = (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (ExprLStmt GhcRn, FreeVars)
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
one
[[(ExprLStmt GhcRn, FreeVars)]]
segs -> [StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative (([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars))
-> [[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
-> [StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
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)]]
[[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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] = (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
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 =
StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
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 [(ExprLStmt GhcRn, FreeVars)]
[(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 =
Bool -> ExprStmtTree -> ExprStmtTree
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts)) (ExprStmtTree -> ExprStmtTree) -> ExprStmtTree -> ExprStmtTree
forall a b. (a -> b) -> a -> b
$
(ExprStmtTree, Int) -> ExprStmtTree
forall a b. (a, b) -> a
fst (Array (Int, Int) (ExprStmtTree, Int)
Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
arr Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
0,Int
n))
where
n :: Int
n = [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts Int -> Int -> Int
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 = (Int, Int)
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
n) [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts
arr :: Array (Int,Int) (ExprStmtTree, Cost)
arr :: Array (Int, Int) (ExprStmtTree, Int)
arr = ((Int, Int), (Int, Int))
-> [((Int, Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))]
-> Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int
0,Int
0),(Int
n,Int
n))
[ ((Int
lo,Int
hi), Int
-> Int
-> (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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
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 Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- [Int
lo..Int
hi] ] of
[] -> String
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall a. HasCallStack => String -> a
panic String
"mkStmtTree"
[[(ExprLStmt GhcRn, FreeVars)]
_one] -> Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
[[(ExprLStmt GhcRn, FreeVars)]]
segs -> ([StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. [StmtTree a] -> StmtTree a
StmtTreeApplicative [StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
trees, [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
costs)
where
bounds :: [(Int, Int)]
bounds = ((Int, Int)
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> (Int, Int))
-> (Int, Int)
-> [[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
-> [(Int, Int)]
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
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
a)) (Int
0,Int
loInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [[(ExprLStmt GhcRn, FreeVars)]]
[[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
segs
([StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
trees,[Int]
costs) = [(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)]
-> ([StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)],
[Int])
forall a b. [(a, b)] -> ([a], [b])
unzip (((Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> [(Int, Int)]
-> [(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int
-> Int
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> (ExprStmtTree, Int)
Int
-> Int
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
split) ([(Int, Int)] -> [(Int, Int)]
forall a. HasCallStack => [a] -> [a]
tail [(Int, Int)]
bounds))
split :: Int -> Int -> (ExprStmtTree, Cost)
split :: Int -> Int -> (ExprStmtTree, Int)
split Int
lo Int
hi
| Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo = ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1)
| Bool
otherwise = (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
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
c1Int -> Int -> Int
forall 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= (((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
lo), Int
1),
((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
| Int
left_cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
right_cost
= ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
left,Int
left_cost), ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall i e. Ix i => Array i e -> i -> e
! Int
hi), Int
1))
| Int
left_cost Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
right_cost
= (((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
forall a. a -> StmtTree a
StmtTreeOne (Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
stmt_arr Array
Int
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> Int
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
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 = (((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> Ordering)
-> [((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))]
-> ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> Int)
-> ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int),
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int))
-> Int
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)
Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
arr Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
right, Int
right_cost) = Array (Int, Int) (ExprStmtTree, Int)
Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
arr Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
loInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
hi)
cost :: ((a, a), (a, a)) -> a
cost ((a
_,a
c1),(a
_,a
c2)) = a
c1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
c2
alternatives :: [((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)
Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
arr Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
lo,Int
k), Array (Int, Int) (ExprStmtTree, Int)
Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
arr Array
(Int, Int)
(StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
-> (Int, Int)
-> (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars),
Int)
forall i e. Ix i => Array i e -> i -> e
! (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
hi))
| Int
k <- [Int
lo .. Int
hiInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
stmtTreeToStmts
:: MonadNames
-> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ( [ExprLStmt GhcRn]
, FreeVars )
stmtTreeToStmts :: MonadNames
-> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
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
| LPat GhcRn -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat GhcRn
pat, (Bool
False,[ExprLStmt GhcRn]
tail') <- MonadNames
-> [ExprLStmt GhcRn] -> Maybe Name -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
monad_names [ExprLStmt GhcRn]
tail Maybe Name
forall a. Maybe a
Nothing
= HsDoFlavour
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsDoFlavour
ctxt [ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XBindStmtRn -> Maybe (SyntaxExpr GhcRn)
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbs
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
, is_body_stmt :: Bool
is_body_stmt = Bool
False
}]
Bool
False [ExprLStmt GhcRn]
tail'
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
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] -> Maybe Name -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
monad_names [ExprLStmt GhcRn]
tail Maybe Name
forall a. Maybe a
Nothing
= HsDoFlavour
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsDoFlavour
ctxt
[ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = Maybe SyntaxExprRn
XApplicativeArgOne GhcRn
forall a. Maybe a
Nothing
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
nlWildPatName
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rhs
, is_body_stmt :: Bool
is_body_stmt = Bool
True
}] Bool
False [ExprLStmt GhcRn]
tail'
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
ctxt (StmtTreeOne (let_stmt :: ExprLStmt GhcRn
let_stmt@(L SrcSpanAnnA
_ LetStmt{}),FreeVars
_))
[ExprLStmt GhcRn]
tail FreeVars
_tail_fvs = do
(pure_name, _) <- HsStmtContext (ZonkAny 0) -> Name -> RnM (Name, FreeVars)
forall fn. HsStmtContext fn -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName (HsDoFlavour -> HsStmtContext (ZonkAny 0)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt) Name
pureAName
return $ case needJoin monad_names tail (Just pure_name) of
(Bool
False, [ExprLStmt GhcRn]
tail') -> (ExprLStmt GhcRn
GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
let_stmt GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
tail', FreeVars
emptyNameSet)
(Bool
True, [ExprLStmt GhcRn]
_) -> (ExprLStmt GhcRn
GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
let_stmt GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
tail, FreeVars
emptyNameSet)
stmtTreeToStmts MonadNames
_monad_names HsDoFlavour
_ctxt (StmtTreeOne (ExprLStmt GhcRn
s,FreeVars
_)) [ExprLStmt GhcRn]
tail FreeVars
_tail_fvs =
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprLStmt GhcRn
GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
s GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcRn]
[GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
tail, FreeVars
emptyNameSet)
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
ctxt (StmtTreeBind ExprStmtTree
before ExprStmtTree
after) [ExprLStmt GhcRn]
tail FreeVars
tail_fvs = do
(stmts1, fvs1) <- MonadNames
-> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
ctxt ExprStmtTree
after [ExprLStmt GhcRn]
tail FreeVars
tail_fvs
let tail1_fvs = [FreeVars] -> FreeVars
unionNameSets (FreeVars
tail_fvs FreeVars -> [FreeVars] -> [FreeVars]
forall a. a -> [a] -> [a]
: ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> FreeVars)
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [FreeVars]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> FreeVars
forall a b. (a, b) -> b
snd (StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. StmtTree a -> [a]
flattenStmtTree ExprStmtTree
StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
after))
(stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
return (stmts2, fvs1 `plusFV` fvs2)
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
ctxt (StmtTreeApplicative [ExprStmtTree]
trees) [ExprLStmt GhcRn]
tail FreeVars
tail_fvs = do
hscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
strict <- xoptM LangExt.Strict
let (stmts', fvss) = unzip pairs
let (need_join, tail') =
if any (hasRefutablePattern strict hscEnv rdrEnv comps) stmts'
then (True, tail)
else needJoin monad_names tail Nothing
(stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss))
where
stmtTreeArg :: HsDoFlavour
-> FreeVars
-> StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
stmtTreeArg HsDoFlavour
_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
_))
= (ApplicativeArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = XBindStmtRn -> Maybe (SyntaxExpr GhcRn)
xbsrn_failOp XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
XBindStmtRn
xbs
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
pat
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp
, is_body_stmt :: Bool
is_body_stmt = Bool
False
}, FreeVars
emptyFVs)
stmtTreeArg HsDoFlavour
_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
_)) =
(ApplicativeArg GhcRn, FreeVars)
-> IOEnv (Env TcGblEnv TcLclEnv) (ApplicativeArg GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApplicativeArgOne
{ xarg_app_arg_one :: XApplicativeArgOne GhcRn
xarg_app_arg_one = Maybe SyntaxExprRn
XApplicativeArgOne GhcRn
forall a. Maybe a
Nothing
, app_arg_pattern :: LPat GhcRn
app_arg_pattern = LPat GhcRn
nlWildPatName
, arg_expr :: XRec GhcRn (HsExpr GhcRn)
arg_expr = XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp
, is_body_stmt :: Bool
is_body_stmt = Bool
True
}, FreeVars
emptyFVs)
stmtTreeArg HsDoFlavour
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 = StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. StmtTree a -> [a]
flattenStmtTree StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
tree
pvarset :: FreeVars
pvarset = [Name] -> FreeVars
mkNameSet (((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [Name])
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CollectFlag GhcRn
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
(IsPass idL, IsPass idR, CollectPass (GhcPass idL)) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [Name])
-> ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
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 [IdP GhcRn]
[Name]
pvars
tup :: XRec GhcRn (HsExpr GhcRn)
tup = [IdP GhcRn] -> XExplicitTuple GhcRn -> XRec GhcRn (HsExpr GhcRn)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkBigLHsVarTup [IdP GhcRn]
[Name]
pvars XExplicitTuple GhcRn
NoExtField
noExtField
(stmts',fvs2) <- MonadNames
-> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ([ExprLStmt GhcRn], FreeVars)
stmtTreeToStmts MonadNames
monad_names HsDoFlavour
ctxt ExprStmtTree
StmtTree
(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
tree [] FreeVars
pvarset
(mb_ret, fvs1) <-
if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let expr = XApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
NoExtField
noExtField (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
noLocA (Name -> HsExpr GhcRn
genHsVar Name
pure_name)) XRec GhcRn (HsExpr GhcRn)
tup
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
, app_stmts = stmts'
, final_expr = mb_ret
, bv_pattern = pat
, stmt_context = ctxt
}
, fvs1 `plusFV` fvs2)
segments
:: [(ExprLStmt GhcRn, FreeVars)]
-> [[(ExprLStmt GhcRn, FreeVars)]]
segments :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
segments [(ExprLStmt GhcRn, FreeVars)]
stmts = [[(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)]]
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)]]
merge ([[(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)]]
-> [[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
forall a b. (a -> b) -> a -> b
$ [[(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)]]
forall a. [a] -> [a]
reverse ([[(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)]]
-> [[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
forall a b. (a -> b) -> a -> b
$ ([(ExprLStmt GhcRn, FreeVars)]
-> [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)])
-> [[(ExprLStmt GhcRn, FreeVars)]]
-> [[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
forall a b. (a -> b) -> [a] -> [b]
map [(ExprLStmt GhcRn, FreeVars)]
-> [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. [a] -> [a]
reverse ([[(ExprLStmt GhcRn, FreeVars)]]
-> [[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]])
-> [[(ExprLStmt GhcRn, FreeVars)]]
-> [[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]]
forall a b. (a -> b) -> a -> b
$ [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk ([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. [a] -> [a]
reverse [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
stmts)
where
allvars :: FreeVars
allvars = [Name] -> FreeVars
mkNameSet (((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [Name])
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CollectFlag GhcRn
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
(IsPass idL, IsPass idR, CollectPass (GhcPass idL)) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [Name])
-> ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> ((GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. (a, b) -> a
fst) [(ExprLStmt GhcRn, FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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)]]
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)]]
rest of
[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
s:[[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
ss | Bool
all_lets -> ([(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)]
-> [(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)]
forall a. [a] -> [a] -> [a]
++ [(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
s) [(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)]]
-> [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
forall a. a -> [a] -> [a]
: [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
ss
[[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
_otherwise -> [(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)]
-> [[(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)]]
forall a. a -> [a] -> [a]
: [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
rest
where
rest :: [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
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)]]
merge [[(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]]
segs
all_lets :: Bool
all_lets = ((GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)
-> Bool)
-> [(GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (LStmt (GhcPass a) b -> Bool
GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b)
-> Bool
forall (a :: Pass) b. LStmt (GhcPass a) b -> Bool
isLetStmt (GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b)
-> Bool)
-> ((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))
-> (GenLocated
(Anno (StmtLR (GhcPass a) (GhcPass a) b))
(StmtLR (GhcPass a) (GhcPass a) b),
b)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
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
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)
-> [(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)]
forall a. a -> [a] -> [a]
: [(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)]
-> [[(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)]]
forall a. a -> [a] -> [a]
: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk [(ExprLStmt GhcRn, FreeVars)]
[(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)]
[(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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
GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr 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 orig :: [(GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
orig@((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)
| FreeVars -> Bool
isEmptyNameSet FreeVars
vars, ExprLStmt GhcRn -> Bool
definitelyLazyPatternBind ExprLStmt GhcRn
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))),
FreeVars)]
orig)
| Bool
otherwise
= ((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)
-> [(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)]
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
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
| LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Bool
forall (a :: Pass) b. LStmt (GhcPass a) b -> Bool
isLetStmt LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
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 (CollectFlag GhcRn
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass) body.
(IsPass idL, IsPass idR, CollectPass (GhcPass idL)) =>
CollectFlag (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]
collectStmtBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders (GenLocated
(Anno (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
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))
definitelyLazyPatternBind :: ExprLStmt GhcRn -> Bool
definitelyLazyPatternBind :: ExprLStmt GhcRn -> Bool
definitelyLazyPatternBind (L SrcSpanAnnA
_ (BindStmt XBindStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_ LPat GhcRn
pat GenLocated SrcSpanAnnA (HsExpr GhcRn)
_)) = LPat GhcRn -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat GhcRn
pat
definitelyLazyPatternBind ExprLStmt GhcRn
_ = Bool
True
definitelyLazyPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern :: forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern (L SrcSpanAnnA
loc Pat (GhcPass p)
pat) =
case Pat (GhcPass p)
pat of
WildPat{} -> Bool
True
VarPat{} -> Bool
True
LazyPat{} -> Bool
True
AsPat XAsPat (GhcPass p)
_ LIdP (GhcPass p)
_ LPat (GhcPass p)
p -> LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat (GhcPass p)
p
ParPat XParPat (GhcPass p)
_ LPat (GhcPass p)
p -> LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat (GhcPass p)
p
ViewPat XViewPat (GhcPass p)
_ LHsExpr (GhcPass p)
_f LPat (GhcPass p)
p -> LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat (GhcPass p)
p
SigPat XSigPat (GhcPass p)
_ LPat (GhcPass p)
p HsPatSigType (NoGhcTc (GhcPass p))
_ -> LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat (GhcPass p)
p
OrPat XOrPat (GhcPass p)
_ NonEmpty (LPat (GhcPass p))
p -> LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern (NonEmpty (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
-> GenLocated SrcSpanAnnA (Pat (GhcPass p))
forall a. NonEmpty a -> a
NE.head NonEmpty (LPat (GhcPass p))
NonEmpty (GenLocated SrcSpanAnnA (Pat (GhcPass p)))
p)
BangPat{} -> Bool
False
ListPat{} -> Bool
False
TuplePat{} -> Bool
False
SumPat{} -> Bool
False
ConPat{} -> Bool
False
LitPat{} -> Bool
False
NPat{} -> Bool
False
NPlusKPat{} -> Bool
False
SplicePat{} -> Bool
False
EmbTyPat{} -> Bool
True
InvisPat{} -> Bool
True
XPat XXPat (GhcPass p)
ext -> case forall (p :: Pass). IsPass p => GhcPass p
ghcPass @p of
GhcPass p
GhcRn
| HsPatExpanded Pat GhcRn
_ Pat GhcRn
p <- XXPat (GhcPass p)
ext
-> LPat GhcRn -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern (SrcSpanAnnA -> Pat GhcRn -> GenLocated SrcSpanAnnA (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Pat GhcRn
p)
GhcPass p
GhcTc -> case XXPat (GhcPass p)
ext of
ExpansionPat Pat GhcRn
_ Pat GhcTc
p -> LPat GhcTc -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern (SrcSpanAnnA -> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Pat GhcTc
p)
CoPat {} -> String -> Bool
forall a. HasCallStack => String -> a
panic String
"definitelyLazyPattern: CoPat"
hasRefutablePattern :: Bool
-> HscEnv
-> GlobalRdrEnv
-> CompleteMatches
-> ApplicativeArg GhcRn -> Bool
hasRefutablePattern :: Bool
-> HscEnv
-> GlobalRdrEnv
-> CompleteMatches
-> ApplicativeArg GhcRn
-> Bool
hasRefutablePattern Bool
is_strict HscEnv
hsc_env GlobalRdrEnv
rdr_env CompleteMatches
comps ApplicativeArg GhcRn
arg =
case ApplicativeArg GhcRn
arg of
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 (Bool -> (ConLikeP GhcRn -> Bool) -> LPat GhcRn -> Bool
forall (p :: Pass).
IsPass p =>
Bool -> (ConLikeP (GhcPass p) -> Bool) -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat Bool
is_strict (HasDebugCallStack =>
HscEnv -> GlobalRdrEnv -> CompleteMatches -> Name -> Bool
HscEnv -> GlobalRdrEnv -> CompleteMatches -> Name -> Bool
irrefutableConLikeRn HscEnv
hsc_env GlobalRdrEnv
rdr_env CompleteMatches
comps) LPat GhcRn
pat)
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) <- [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
-> Maybe
([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)],
[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)],
[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)])
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)]
[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
stmts
= if Bool -> Bool
not ([(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
lets)
then ([(ExprLStmt GhcRn, FreeVars)]
[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
lets, [(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
binds[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
rest)
else ([(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
lets[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall a. [a] -> [a] -> [a]
++[(LStmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)), FreeVars)]
[(GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
binds, [(ExprLStmt GhcRn, FreeVars)]
[(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 = [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
-> FreeVars
-> [(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)]
-> Maybe
([(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)],
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))),
FreeVars)])
forall {p :: Pass} {idR} {body} {idR} {body} {l}.
(XBindStmt (GhcPass p) idR body ~ XBindStmt (GhcPass p) idR body,
IdGhcP p ~ Name,
XLetStmt (GhcPass p) idR body ~ XLetStmt (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)]
[(GenLocated
SrcSpanAnnA (StmtLR GhcRn 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, LPat (GhcPass p) -> Bool
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Bool
definitelyLazyPattern LPat (GhcPass p)
pat
= [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> FreeVars
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> Maybe
([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets ((l
-> StmtLR (GhcPass p) idR body
-> GenLocated l (StmtLR (GhcPass p) idR body)
forall l e. l -> e -> GenLocated l e
L l
loc (XBindStmt (GhcPass p) idR body
-> LPat (GhcPass p) -> body -> StmtLR (GhcPass p) idR body
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt (GhcPass p) idR body
XBindStmt (GhcPass p) idR body
xbs LPat (GhcPass p)
pat body
body), FreeVars
fvs) (GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. a -> [a] -> [a]
: [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep)
FreeVars
bndrs' [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest
where bndrs' :: FreeVars
bndrs' = FreeVars
bndrs FreeVars -> FreeVars -> FreeVars
`unionNameSet` [Name] -> FreeVars
mkNameSet (CollectFlag (GhcPass p) -> LPat (GhcPass p) -> [IdP (GhcPass p)]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag (GhcPass p)
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 ((l
-> StmtLR (GhcPass p) idR body
-> GenLocated l (StmtLR (GhcPass p) idR body)
forall l e. l -> e -> GenLocated l e
L l
loc (XLetStmt (GhcPass p) idR body
-> HsLocalBindsLR (GhcPass p) idR -> StmtLR (GhcPass p) idR body
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt (GhcPass p) idR body
XLetStmt (GhcPass p) idR body
noExtField HsLocalBindsLR (GhcPass p) idR
binds), FreeVars
fvs) (GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. a -> [a] -> [a]
: [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets) [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
bndrs [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
rest
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ [] FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ = Maybe
([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. Maybe a
Nothing
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)
_] FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
_ = Maybe
([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. Maybe a
Nothing
go [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep FreeVars
_ [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
stmts = ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
-> Maybe
([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)],
[(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)])
forall a. a -> Maybe a
Just ([(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
lets, [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
-> [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
forall a. [a] -> [a]
reverse [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
indep, [(GenLocated l (StmtLR (GhcPass p) idR body), FreeVars)]
stmts)
mkApplicativeStmt
:: HsDoFlavour
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt :: HsDoFlavour
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt HsDoFlavour
ctxt [ApplicativeArg GhcRn]
args Bool
need_join [ExprLStmt GhcRn]
body_stmts
= do { (fmap_op, fvs1) <- HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName (HsDoFlavour -> HsStmtContext (GenLocated SrcSpanAnnN Name)
forall fn. HsDoFlavour -> HsStmtContext fn
HsDoStmt HsDoFlavour
ctxt) Name
fmapName
; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
; (mb_join, fvs3) <-
if need_join then
do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
; loc <- getSrcSpanM
; let applicative_stmt = SrcSpanAnnA
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall a b. (a -> b) -> a -> b
$ XXStmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall idL idR body. XXStmtLR idL idR body -> StmtLR idL idR body
XStmtLR (XXStmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> XXStmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ XApplicativeStmt GhcRn GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> Maybe (SyntaxExpr GhcRn)
-> ApplicativeStmt GhcRn GhcRn
forall idL idR.
XApplicativeStmt idL idR
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> ApplicativeStmt idL idR
ApplicativeStmt NoExtField
XApplicativeStmt GhcRn GhcRn
noExtField
([SyntaxExprRn]
-> [ApplicativeArg GhcRn] -> [(SyntaxExprRn, ApplicativeArg GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
zip (SyntaxExprRn
fmap_op SyntaxExprRn -> [SyntaxExprRn] -> [SyntaxExprRn]
forall a. a -> [a] -> [a]
: SyntaxExprRn -> [SyntaxExprRn]
forall a. a -> [a]
repeat SyntaxExprRn
ap_op) [ApplicativeArg GhcRn]
args)
Maybe (SyntaxExpr GhcRn)
Maybe SyntaxExprRn
mb_join
; return ( applicative_stmt : body_stmts
, fvs1 `plusFV` fvs2 `plusFV` fvs3) }
needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> Maybe Name
-> (Bool, [ExprLStmt GhcRn])
needJoin :: MonadNames
-> [ExprLStmt GhcRn] -> Maybe Name -> (Bool, [ExprLStmt GhcRn])
needJoin MonadNames
_monad_names [] Maybe Name
_mb_pure = (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)] Maybe Name
mb_pure
| Just (XRec GhcRn (HsExpr GhcRn)
arg, Maybe Bool
noret) <- MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe Name
-> Maybe (XRec GhcRn (HsExpr GhcRn), Maybe Bool)
isReturnApp MonadNames
monad_names XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e Maybe Name
mb_pure =
(Bool
False, [SrcSpanAnnA
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Maybe Bool
-> SyntaxExpr GhcRn
-> StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall idL idR body.
XLastStmt idL idR body
-> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body
LastStmt XLastStmt GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
NoExtField
noExtField XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg Maybe Bool
noret SyntaxExpr GhcRn
t)])
needJoin MonadNames
_monad_names [ExprLStmt GhcRn]
stmts Maybe Name
_mb_pure = (Bool
True, [ExprLStmt GhcRn]
stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe Name
-> Maybe (LHsExpr GhcRn, Maybe Bool)
isReturnApp :: MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe Name
-> Maybe (XRec GhcRn (HsExpr GhcRn), Maybe Bool)
isReturnApp MonadNames
monad_names (L SrcSpanAnnA
_ (HsPar XPar GhcRn
_ XRec GhcRn (HsExpr GhcRn)
expr)) Maybe Name
mb_pure =
MonadNames
-> XRec GhcRn (HsExpr GhcRn)
-> Maybe Name
-> Maybe (XRec GhcRn (HsExpr GhcRn), Maybe Bool)
isReturnApp MonadNames
monad_names XRec GhcRn (HsExpr GhcRn)
expr Maybe Name
mb_pure
isReturnApp MonadNames
monad_names (L SrcSpanAnnA
loc HsExpr GhcRn
e) Maybe Name
mb_pure = case HsExpr GhcRn
e of
OpApp XOpApp GhcRn
x XRec GhcRn (HsExpr GhcRn)
l XRec GhcRn (HsExpr GhcRn)
op XRec GhcRn (HsExpr GhcRn)
r
| Just Name
pure_name <- Maybe Name
mb_pure, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
l, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_dollar XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op ->
(GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
x (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Name -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall {l} {e}.
GenLocated l e -> Name -> GenLocated l (HsExpr GhcRn)
to_pure XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
l Name
pure_name) XRec GhcRn (HsExpr GhcRn)
op XRec GhcRn (HsExpr GhcRn)
r), Maybe Bool
forall a. Maybe a
Nothing)
| GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
l, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_dollar XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
op -> (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
forall a. a -> Maybe a
Just (XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
r, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
HsApp XApp GhcRn
x XRec GhcRn (HsExpr GhcRn)
f XRec GhcRn (HsExpr GhcRn)
arg
| Just Name
pure_name <- Maybe Name
mb_pure, GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
f ->
(GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XApp GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
x (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> Name -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall {l} {e}.
GenLocated l e -> Name -> GenLocated l (HsExpr GhcRn)
to_pure XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
f Name
pure_name) XRec GhcRn (HsExpr GhcRn)
arg), Maybe Bool
forall a. Maybe a
Nothing)
| GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_return XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
f -> (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
forall a. a -> Maybe a
Just (XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
HsExpr GhcRn
_otherwise -> Maybe (XRec GhcRn (HsExpr GhcRn), Maybe Bool)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcRn), Maybe Bool)
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)
GenLocated l (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)
GenLocated l (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 = (IdP GhcRn -> Bool)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
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
Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
return_name MonadNames
monad_names
Bool -> Bool -> Bool
|| IdP GhcRn
Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== MonadNames -> Name
pure_name MonadNames
monad_names)
to_pure :: GenLocated l e -> Name -> GenLocated l (HsExpr GhcRn)
to_pure (L l
loc e
_) Name
pure_name = l -> HsExpr GhcRn -> GenLocated l (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L l
loc (Name -> HsExpr GhcRn
genHsVar Name
pure_name)
is_dollar :: GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
is_dollar = (IdP GhcRn -> Bool)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Bool
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 -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey)
checkEmptyStmts :: HsStmtContextRn -> RnM ()
checkEmptyStmts :: HsStmtContextRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEmptyStmts HsStmtContextRn
ctxt
= (EmptyStatementGroupErrReason -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> Maybe EmptyStatementGroupErrReason
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (EmptyStatementGroupErrReason -> TcRnMessage)
-> EmptyStatementGroupErrReason
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmptyStatementGroupErrReason -> TcRnMessage
TcRnEmptyStmtsGroup) Maybe EmptyStatementGroupErrReason
mb_err
where
mb_err :: Maybe EmptyStatementGroupErrReason
mb_err = case HsStmtContextRn
ctxt of
PatGuard {} -> Maybe EmptyStatementGroupErrReason
forall a. Maybe a
Nothing
ParStmtCtxt {} -> EmptyStatementGroupErrReason -> Maybe EmptyStatementGroupErrReason
forall a. a -> Maybe a
Just EmptyStatementGroupErrReason
EmptyStmtsGroupInParallelComp
TransStmtCtxt {} -> EmptyStatementGroupErrReason -> Maybe EmptyStatementGroupErrReason
forall a. a -> Maybe a
Just EmptyStatementGroupErrReason
EmptyStmtsGroupInTransformListComp
HsDoStmt HsDoFlavour
flav -> EmptyStatementGroupErrReason -> Maybe EmptyStatementGroupErrReason
forall a. a -> Maybe a
Just (EmptyStatementGroupErrReason
-> Maybe EmptyStatementGroupErrReason)
-> EmptyStatementGroupErrReason
-> Maybe EmptyStatementGroupErrReason
forall a b. (a -> b) -> a -> b
$ HsDoFlavour -> EmptyStatementGroupErrReason
EmptyStmtsGroupInDoNotation HsDoFlavour
flav
HsStmtContextRn
ArrowExpr -> EmptyStatementGroupErrReason -> Maybe EmptyStatementGroupErrReason
forall a. a -> Maybe a
Just EmptyStatementGroupErrReason
EmptyStmtsGroupInArrowNotation
checkLastStmt :: AnnoBody body
=> HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt :: forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt HsStmtContextRn
ctxt lstmt :: LStmt GhcPs (LocatedA (body GhcPs))
lstmt@(L SrcSpanAnnA
loc StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt)
= case HsStmtContextRn
ctxt of
HsDoStmt HsDoFlavour
ListComp -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_comp
HsDoStmt HsDoFlavour
MonadComp -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_comp
HsDoStmt DoExpr{} -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
HsDoStmt MDoExpr{} -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
HsStmtContextRn
ArrowExpr -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_do
HsStmtContextRn
_ -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
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
_ -> GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
-> GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (LocatedA (body GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
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 {} -> GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt
StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
_ -> do { TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HsStmtContextRn -> UnexpectedStatement -> TcRnMessage
TcRnLastStmtNotExpr HsStmtContextRn
ctxt
(UnexpectedStatement -> TcRnMessage)
-> UnexpectedStatement -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ StmtLR GhcPs GhcPs (LocatedA (body GhcPs)) -> UnexpectedStatement
forall body.
Outputable (StmtLR GhcPs GhcPs body) =>
StmtLR GhcPs GhcPs body -> UnexpectedStatement
UnexpectedStatement StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt
; GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt }
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 {} -> GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt
StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
_ -> String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkLastStmt" (GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt)
check_other :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
check_other
= do { HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContextRn
ctxt LStmt GhcPs (LocatedA (body GhcPs))
lstmt; GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LStmt GhcPs (LocatedA (body GhcPs))
GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))
lstmt }
checkStmt :: AnnoBody body
=> HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM ()
checkStmt :: forall (body :: * -> *).
AnnoBody body =>
HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
checkStmt HsStmtContextRn
ctxt (L SrcSpanAnnA
_ StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt)
= do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case okStmt dflags ctxt stmt of
Validity' (Maybe Extension)
IsValid -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
NotValid Maybe Extension
ext -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
HsStmtContextRn
-> UnexpectedStatement -> Maybe Extension -> TcRnMessage
TcRnUnexpectedStatementInContext
HsStmtContextRn
ctxt (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)) -> UnexpectedStatement
forall body.
Outputable (StmtLR GhcPs GhcPs body) =>
StmtLR GhcPs GhcPs body -> UnexpectedStatement
UnexpectedStatement StmtLR GhcPs GhcPs (LocatedA (body GhcPs))
stmt) Maybe Extension
ext }
emptyInvalid :: Validity' (Maybe LangExt.Extension)
emptyInvalid :: Validity' (Maybe Extension)
emptyInvalid = Maybe Extension -> Validity' (Maybe Extension)
forall a. a -> Validity' a
NotValid Maybe Extension
forall a. Maybe a
Nothing
okStmt, okDoStmt, okCompStmt, okParStmt
:: DynFlags -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
okStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case HsStmtContextRn
ctxt of
PatGuard {} -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe Extension)
forall (body :: * -> *).
Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe Extension)
okPatGuardStmt Stmt GhcPs (LocatedA (body GhcPs))
stmt
ParStmtCtxt HsStmtContextRn
ctxt -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okParStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsDoStmt HsDoFlavour
flavour -> DynFlags
-> HsDoFlavour
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsDoFlavour
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoFlavourStmt DynFlags
dflags HsDoFlavour
flavour HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsStmtContextRn
ArrowExpr -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
TransStmtCtxt HsStmtContextRn
ctxt -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
okDoFlavourStmt
:: DynFlags -> HsDoFlavour -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
okDoFlavourStmt :: forall (body :: * -> *).
DynFlags
-> HsDoFlavour
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoFlavourStmt DynFlags
dflags HsDoFlavour
flavour HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt = case HsDoFlavour
flavour of
DoExpr{} -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
MDoExpr{} -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsDoFlavour
GhciStmtCtxt -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsDoFlavour
ListComp -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okCompStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
HsDoFlavour
MonadComp -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okCompStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
okPatGuardStmt :: forall (body :: * -> *).
Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe Extension)
okPatGuardStmt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
BodyStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
BindStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
LetStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> Validity' (Maybe Extension)
emptyInvalid
okParStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okParStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
LetStmt XLetStmt GhcPs GhcPs (LocatedA (body GhcPs))
_ (HsIPBinds {}) -> Validity' (Maybe Extension)
emptyInvalid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okStmt DynFlags
dflags HsStmtContextRn
ctxt Stmt GhcPs (LocatedA (body GhcPs))
stmt
okDoStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okDoStmt DynFlags
dflags HsStmtContextRn
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' (Maybe Extension)
forall a. Validity' a
IsValid
| HsStmtContextRn
ArrowExpr <- HsStmtContextRn
ctxt -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
| Bool
otherwise -> Maybe Extension -> Validity' (Maybe Extension)
forall a. a -> Validity' a
NotValid (Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
LangExt.RecursiveDo)
BindStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
LetStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
BodyStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
Stmt GhcPs (LocatedA (body GhcPs))
_ -> Validity' (Maybe Extension)
emptyInvalid
okCompStmt :: forall (body :: * -> *).
DynFlags
-> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs))
-> Validity' (Maybe Extension)
okCompStmt DynFlags
dflags HsStmtContextRn
_ Stmt GhcPs (LocatedA (body GhcPs))
stmt
= case Stmt GhcPs (LocatedA (body GhcPs))
stmt of
BindStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
LetStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
BodyStmt {} -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
ParStmt {}
| Extension
LangExt.ParallelListComp Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
| Bool
otherwise -> Maybe Extension -> Validity' (Maybe Extension)
forall a. a -> Validity' a
NotValid (Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
LangExt.ParallelListComp)
TransStmt {}
| Extension
LangExt.TransformListComp Extension -> DynFlags -> Bool
`xopt` DynFlags
dflags -> Validity' (Maybe Extension)
forall a. Validity' a
IsValid
| Bool
otherwise -> Maybe Extension -> Validity' (Maybe Extension)
forall a. a -> Validity' a
NotValid (Extension -> Maybe Extension
forall a. a -> Maybe a
Just Extension
LangExt.TransformListComp)
RecStmt {} -> Validity' (Maybe Extension)
emptyInvalid
LastStmt {} -> Validity' (Maybe Extension)
emptyInvalid
checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
checkTupleSection :: [HsTupArg GhcPs] -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTupleSection [HsTupArg GhcPs]
args
= do { tuple_section <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg :: TcRnMessage
msg :: TcRnMessage
msg = TcRnMessage
TcRnIllegalTupleSection
sectionErr :: HsExpr GhcPs -> TcRnMessage
sectionErr :: HsExpr GhcPs -> TcRnMessage
sectionErr = HsExpr GhcPs -> TcRnMessage
TcRnSectionWithoutParentheses
badIpBinds :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) -> TcRnMessage
badIpBinds :: Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
-> TcRnMessage
badIpBinds = Either (HsLocalBinds GhcPs) (HsLocalBindsLR GhcRn GhcPs)
-> TcRnMessage
TcRnIllegalImplicitParameterBindings
monadFailOp :: LPat GhcRn
-> HsStmtContextRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp :: LPat GhcRn
-> HsStmtContextRn -> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
monadFailOp LPat GhcRn
pat HsStmtContextRn
ctxt = do
strict <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.Strict
hscEnv <- getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat
-> return (Nothing, emptyFVs)
| not (isMonadStmtContext ctxt)
-> return (Nothing, emptyFVs)
| otherwise
-> getMonadFailOp ctxt
getMonadFailOp :: HsStmtContext fn -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp :: forall fn.
HsStmtContext fn -> RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
getMonadFailOp HsStmtContext fn
ctxt
= do { xOverloadedStrings <- (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings) IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; return (Just fail, fvs)
}
where
isQualifiedDo :: Bool
isQualifiedDo = Maybe ModuleName -> Bool
forall a. Maybe a -> Bool
isJust (HsStmtContext fn -> Maybe ModuleName
forall fn. HsStmtContext fn -> Maybe ModuleName
qualifiedDoModuleName_maybe HsStmtContext fn
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
(failName, failFvs) <- HsStmtContext fn -> Name -> RnM (Name, FreeVars)
forall fn. HsStmtContext fn -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName HsStmtContext fn
ctxt Name
failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
let arg_lit = FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"arg")
arg_name <- newSysName arg_lit
let arg_syn_expr = IdP GhcRn -> XRec GhcRn (HsExpr GhcRn)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcRn
Name
arg_name
body :: LHsExpr GhcRn =
nlHsApp (noLocA (genHsVar failName))
(nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam (noLocA [noLocA $ VarPat noExtField $ noLocA arg_name]) body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
| Bool
otherwise = HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
forall fn.
HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo HsStmtContext fn
ctxt Name
failMName
rnHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnHsIf :: LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> TcM (HsExpr GhcRn, FreeVars)
rnHsIf LHsExpr GhcPs
p LHsExpr GhcPs
b1 LHsExpr GhcPs
b2
= do { (p', fvP) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
; let fvs_if = [FreeVars] -> FreeVars
plusFVs [FreeVars
fvP, FreeVars
fvB1, FreeVars
fvB2]
rn_if = XIf GhcRn
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
NoExtField
noExtField XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
p' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
b1' XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
b2'
; mb_ite <- lookupIfThenElse
; case mb_ite of
Maybe Name
Nothing
-> (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 [XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
p', XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
b1', XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
b2']
fvs :: FreeVars
fvs = [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs_if, Name -> FreeVars
unitFV Name
ite_name]
; (HsExpr GhcRn, FreeVars) -> TcM (HsExpr GhcRn, FreeVars)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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) } }
mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
mkGetField :: Name
-> XRec GhcRn (HsExpr GhcRn)
-> LocatedAn NoEpAnns FieldLabelString
-> HsExpr GhcRn
mkGetField Name
get_field XRec GhcRn (HsExpr GhcRn)
arg LocatedAn NoEpAnns FieldLabelString
field = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc ([XRec GhcRn (HsExpr GhcRn)] -> XRec GhcRn (HsExpr GhcRn)
forall a. HasCallStack => [a] -> a
head ([XRec GhcRn (HsExpr GhcRn)] -> XRec GhcRn (HsExpr GhcRn))
-> [XRec GhcRn (HsExpr GhcRn)] -> XRec GhcRn (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> LocatedAn NoEpAnns FieldLabelString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field [XRec GhcRn (HsExpr GhcRn)
arg] LocatedAn NoEpAnns FieldLabelString
field)
mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
mkSetField :: Name
-> XRec GhcRn (HsExpr GhcRn)
-> LocatedAn NoEpAnns FieldLabelString
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
mkSetField Name
set_field XRec GhcRn (HsExpr GhcRn)
a (L EpAnn NoEpAnns
_ (FieldLabelString 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] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
mkGet :: Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> LocatedAn NoEpAnns FieldLabelString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field l :: [XRec GhcRn (HsExpr GhcRn)]
l@(XRec GhcRn (HsExpr GhcRn)
r : [XRec GhcRn (HsExpr GhcRn)]
_) (L EpAnn NoEpAnns
_ (FieldLabelString FastString
field)) =
HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated 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) GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall a. a -> [a] -> [a]
: [XRec GhcRn (HsExpr GhcRn)]
[GenLocated SrcSpanAnnA (HsExpr GhcRn)]
l
mkGet Name
_ [] LocatedAn NoEpAnns FieldLabelString
_ = String -> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall a. HasCallStack => String -> a
panic String
"mkGet : The impossible has happened!"
mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
mkSet :: Name
-> XRec GhcRn (HsExpr GhcRn)
-> (LocatedAn NoEpAnns FieldLabelString, XRec GhcRn (HsExpr GhcRn))
-> XRec GhcRn (HsExpr GhcRn)
mkSet Name
set_field XRec GhcRn (HsExpr GhcRn)
acc (LocatedAn NoEpAnns FieldLabelString
field, XRec GhcRn (HsExpr GhcRn)
g) = HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan (Name
-> XRec GhcRn (HsExpr GhcRn)
-> LocatedAn NoEpAnns FieldLabelString
-> XRec GhcRn (HsExpr GhcRn)
-> HsExpr GhcRn
mkSetField Name
set_field XRec GhcRn (HsExpr GhcRn)
g LocatedAn NoEpAnns FieldLabelString
field XRec GhcRn (HsExpr GhcRn)
acc)
mkProjection :: Name -> Name -> NonEmpty FieldLabelString -> HsExpr GhcRn
mkProjection :: Name -> Name -> NonEmpty FieldLabelString -> HsExpr GhcRn
mkProjection Name
getFieldName Name
circName (FieldLabelString
field :| [FieldLabelString]
fields) = (HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn)
-> HsExpr GhcRn -> [FieldLabelString] -> HsExpr GhcRn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn
f (FieldLabelString -> HsExpr GhcRn
proj FieldLabelString
field) [FieldLabelString]
fields
where
f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn
f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn
f HsExpr GhcRn
acc FieldLabelString
field = Name -> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
genHsApps Name
circName ([XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn)
-> [XRec GhcRn (HsExpr GhcRn)] -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ (HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn))
-> [HsExpr GhcRn] -> [XRec GhcRn (HsExpr GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcRn -> XRec GhcRn (HsExpr GhcRn)
HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated an a
wrapGenSpan [FieldLabelString -> HsExpr GhcRn
proj FieldLabelString
field, HsExpr GhcRn
acc]
proj :: FieldLabelString -> HsExpr GhcRn
proj :: FieldLabelString -> HsExpr GhcRn
proj (FieldLabelString 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
_ (HsFieldBind { hfbLHS :: forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS = (L EpAnn NoEpAnns
_ (FieldLabelStrings [XRec GhcRn (DotFieldOcc GhcRn)]
flds')), hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg } ))
= let {
; flds :: [LocatedAn NoEpAnns FieldLabelString]
flds = (GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)
-> LocatedAn NoEpAnns FieldLabelString)
-> [GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)]
-> [LocatedAn NoEpAnns FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ((DotFieldOcc GhcRn -> FieldLabelString)
-> GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)
-> LocatedAn NoEpAnns FieldLabelString
forall a b.
(a -> b)
-> GenLocated (EpAnn NoEpAnns) a -> GenLocated (EpAnn NoEpAnns) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString)
-> (DotFieldOcc GhcRn -> GenLocated SrcSpanAnnN FieldLabelString)
-> DotFieldOcc GhcRn
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotFieldOcc GhcRn -> XRec GhcRn FieldLabelString
DotFieldOcc GhcRn -> GenLocated SrcSpanAnnN FieldLabelString
forall p. DotFieldOcc p -> XRec p FieldLabelString
dfoLabel)) [XRec GhcRn (DotFieldOcc GhcRn)]
[GenLocated (EpAnn NoEpAnns) (DotFieldOcc GhcRn)]
flds'
; final :: LocatedAn NoEpAnns FieldLabelString
final = [LocatedAn NoEpAnns FieldLabelString]
-> LocatedAn NoEpAnns FieldLabelString
forall a. HasCallStack => [a] -> a
last [LocatedAn NoEpAnns FieldLabelString]
flds
; fields :: [LocatedAn NoEpAnns FieldLabelString]
fields = [LocatedAn NoEpAnns FieldLabelString]
-> [LocatedAn NoEpAnns FieldLabelString]
forall a. HasCallStack => [a] -> [a]
init [LocatedAn NoEpAnns FieldLabelString]
flds
; getters :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters = \GenLocated SrcSpanAnnA (HsExpr GhcRn)
a -> ([GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> LocatedAn NoEpAnns FieldLabelString
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)])
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [LocatedAn NoEpAnns FieldLabelString]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Name
-> [XRec GhcRn (HsExpr GhcRn)]
-> LocatedAn NoEpAnns FieldLabelString
-> [XRec GhcRn (HsExpr GhcRn)]
mkGet Name
get_field) [GenLocated SrcSpanAnnA (HsExpr GhcRn)
a] [LocatedAn NoEpAnns FieldLabelString]
fields
; zips :: GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
zips = \GenLocated SrcSpanAnnA (HsExpr GhcRn)
a -> (LocatedAn NoEpAnns FieldLabelString
final, [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a. HasCallStack => [a] -> a
head (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters GenLocated SrcSpanAnnA (HsExpr GhcRn)
a)) (LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
forall a. a -> [a] -> [a]
: [LocatedAn NoEpAnns FieldLabelString]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([LocatedAn NoEpAnns FieldLabelString]
-> [LocatedAn NoEpAnns FieldLabelString]
forall a. [a] -> [a]
reverse [LocatedAn NoEpAnns FieldLabelString]
fields) ([GenLocated SrcSpanAnnA (HsExpr GhcRn)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
forall a. HasCallStack => [a] -> [a]
tail (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [GenLocated SrcSpanAnnA (HsExpr GhcRn)]
getters GenLocated SrcSpanAnnA (HsExpr GhcRn)
a))
}
in (\XRec GhcRn (HsExpr GhcRn)
a -> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> (LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
-> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Name
-> XRec GhcRn (HsExpr GhcRn)
-> (LocatedAn NoEpAnns FieldLabelString, XRec GhcRn (HsExpr GhcRn))
-> XRec GhcRn (HsExpr GhcRn)
mkSet Name
set_field) GenLocated SrcSpanAnnA (HsExpr GhcRn)
arg (GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> [(LocatedAn NoEpAnns FieldLabelString,
GenLocated SrcSpanAnnA (HsExpr GhcRn))]
zips XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (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 = (HsExpr GhcRn
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsExpr GhcRn)
-> HsExpr GhcRn
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> HsExpr GhcRn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
HsExpr GhcRn
-> GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsExpr GhcRn
fieldUpdate (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc XRec GhcRn (HsExpr GhcRn)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
exp) [LHsRecUpdProj GhcRn]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
updates
where
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate HsExpr GhcRn
acc LHsRecUpdProj GhcRn
lpu = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn)
-> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
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) (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall an a. HasAnnotation an => a -> GenLocated 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
(u, fvs) <- [(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
[FreeVars])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> ([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
[FreeVars]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn)))],
[FreeVars])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcRn))
(GenLocated SrcSpanAnnA (HsExpr GhcRn))),
FreeVars)
rnRecUpdProj [LHsRecUpdProj GhcPs]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
(GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
us
pure (u, plusFVs fvs)
where
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj (L SrcSpanAnnA
l (HsFieldBind XHsFieldBind
(GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs))
_ GenLocated (EpAnn NoEpAnns) (FieldLabelStrings GhcPs)
fs GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg Bool
pun))
= do { (arg, fv) <- LHsExpr GhcPs -> RnM (XRec GhcRn (HsExpr GhcRn), FreeVars)
rnLExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
arg
; return $
(L l (HsFieldBind {
hfbAnn = noAnn
, hfbLHS = fmap rnFieldLabelStrings fs
, hfbRHS = arg
, hfbPun = pun }), fv ) }