module GHC.Rename.Expr (
rnLExpr, rnExpr, rnStmts,
AnnoBody
) where
import GHC.Prelude
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
, rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env ( isBrackStage )
import GHC.Tc.Utils.Monad
import GHC.Unit.Module ( getModule, isInteractiveModule )
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
, bindLocalNames
, mapMaybeFvRn, mapFvRn
, warnUnusedLocalBinds, typeAppErr
, checkUnusedRecordWildcard
, wrapGenSpan, genHsIntegralLit, genHsTyLit
, genHsVar, genLHsVar, genHsApp, genHsApps
, genAppType )
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
import GHC.Rename.Pat
import GHC.Driver.Session
import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Fixity
import GHC.Types.Hint (suggestExtension)
import GHC.Types.Id.Make
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.List.SetOps ( removeDups )
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc
import Control.Monad
import GHC.Builtin.Types ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
import Data.List (unzip4, minimumBy)
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
rnExprs ls = rnExprs' ls emptyUniqSet
where
rnExprs' [] acc = return ([], acc)
rnExprs' (expr:exprs) acc =
do { (expr', fvExpr) <- rnLExpr expr
; let acc' = acc `plusFV` fvExpr
; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
; return (expr':exprs', fvExprs) }
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr = wrapLocFstMA rnExpr
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
; return (HsVar noExtField (L (la2na l) name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v = do
deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables
unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())
return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)
rnExpr (HsVar _ (L l v))
= do { dflags <- getDynFlags
; mb_name <- lookupExprOccRn v
; case mb_name of {
Nothing -> rnUnboundVar v ;
Just (NormalGreName name)
| name == nilDataConName
, xopt LangExt.OverloadedLists dflags
-> rnExpr (ExplicitList noAnn [])
| otherwise
-> finishHsVar (L (na2la l) name) ;
Just (FieldGreName fl)
-> do { let sel_name = flSelector fl
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod sel_name) $
checkThLocalName sel_name
; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
}
}
}
rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs)
rnExpr (HsUnboundVar _ v)
= return (HsUnboundVar noExtField v, emptyFVs)
rnExpr (HsOverLabel _ v)
= do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
; return ( mkExpandedExpr (HsOverLabel noAnn v) $
HsAppType noExtField (genLHsVar from_label) hs_ty_arg
, fvs ) }
where
hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
HsTyLit noExtField (HsStrTy NoSourceText v)
rnExpr (HsLit x lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
; return (HsLit x (convertLit lit), emptyFVs) } }
rnExpr (HsLit x lit)
= do { rnLit lit
; return (HsLit x(convertLit lit), emptyFVs) }
rnExpr (HsOverLit x lit)
= do { ((lit', mb_neg), fvs) <- rnOverLit lit
; case mb_neg of
Nothing -> return (HsOverLit x lit', fvs)
Just neg ->
return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit'))
, fvs ) }
rnExpr (HsApp x fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnLExpr arg
; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
rnExpr (HsAppType _ fun arg)
= do { type_app <- xoptM LangExt.TypeApplications
; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
; (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) }
rnExpr (OpApp _ e1 op e2)
= do { (e1', fv_e1) <- rnLExpr e1
; (e2', fv_e2) <- rnLExpr e2
; (op', fv_op) <- rnLExpr op
; fixity <- case op' of
L _ (HsVar _ (L _ n)) -> lookupFixityRn n
L _ (HsRecSel _ f) -> lookupFieldFixityRn f
_ -> return (Fixity NoSourceText minPrecedence InfixL)
; lexical_negation <- xoptM LangExt.LexicalNegation
; let negation_handling | lexical_negation = KeepNegationIntact
| otherwise = ReassociateNegation
; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
rnExpr (NegApp _ e _)
= do { (e', fv_e) <- rnLExpr e
; (neg_name, fv_neg) <- lookupSyntax negateName
; final_e <- mkNegAppRn e' neg_name
; return (final_e, fv_e `plusFV` fv_neg) }
rnExpr (HsGetField _ e f)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; (e, fv_e) <- rnLExpr e
; let f' = rnDotFieldOcc f
; return ( mkExpandedExpr
(HsGetField noExtField e f')
(mkGetField getField e (fmap (unLoc . dfoLabel) f'))
, fv_e `plusFV` fv_getField ) }
rnExpr (HsProjection _ fs)
= do { (getField, fv_getField) <- lookupSyntaxName getFieldName
; circ <- lookupOccRn compose_RDR
; let fs' = fmap rnDotFieldOcc fs
; return ( mkExpandedExpr
(HsProjection noExtField fs')
(mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))
, unitFV circ `plusFV` fv_getField) }
rnExpr e@(HsTypedBracket _ br_body) = rnTypedBracket e br_body
rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body
rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)
= do { (section', fvs) <- rnSection section
; return (HsPar x lpar (L loc section') rpar, fvs) }
rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)
= do { (section', fvs) <- rnSection section
; return (HsPar x lpar (L loc section') rpar, fvs) }
rnExpr (HsPar x lpar e rpar)
= do { (e', fvs_e) <- rnLExpr e
; return (HsPar x lpar e' rpar, fvs_e) }
rnExpr expr@(SectionL {})
= do { addErr (sectionErr expr); rnSection expr }
rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr }
rnExpr (HsPragE x prag expr)
= do { (expr', fvs_expr) <- rnLExpr expr
; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
where
rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
; return (HsLam x matches', fvMatch) }
rnExpr (HsLamCase x lc_variant matches)
= do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches
; return (HsLamCase x lc_variant matches', fvs_ms) }
rnExpr (HsCase _ expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnExpr (HsLet _ tkLet binds tkIn expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
{ (expr',fvExpr) <- rnLExpr expr
; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }
rnExpr (HsDo _ do_or_lc (L l stmts))
= do { ((stmts1, _), fvs1) <-
rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
(\ _ -> return ((), emptyFVs))
; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
rnExpr (ExplicitList _ exps)
= do { (exps', fvs) <- rnExprs 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
; let rn_list = ExplicitList noExtField exps'
lit_n = mkIntegralLit (length exps)
hs_lit = genHsIntegralLit lit_n
exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
; return ( mkExpandedExpr rn_list exp_list
, fvs `plusFV` fvs') } }
rnExpr (ExplicitTuple _ tup_args boxity)
= do { checkTupleSection tup_args
; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }
where
rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e
; return (Present x e', fvs) }
rnTupArg (Missing _) = return (Missing noExtField, emptyFVs)
rnExpr (ExplicitSum _ alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
; return (ExplicitSum noExtField alt arity expr', fvs) }
rnExpr (RecordCon { rcon_con = con_id
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
= do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = 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 l n = HsVar noExtField (L (noAnnSrcSpan l) n)
rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)
; return (L l (fld { hfbRHS = arg' }), fvs) }
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
= case rbinds of
Left flds ->
do { ; (e, fv_e) <- rnLExpr expr
; (rs, fv_rs) <- rnHsRecUpdFields flds
; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs )
}
Right flds ->
do { ; unlessXOptM LangExt.RebindableSyntax $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."
; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]
; punsEnabled <-xoptM LangExt.NamedFieldPuns
; unless (null punnedFields || punsEnabled) $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
text "For this to work enable NamedFieldPuns."
; (getField, fv_getField) <- lookupSyntaxName getFieldName
; (setField, fv_setField) <- lookupSyntaxName setFieldName
; (e, fv_e) <- rnLExpr expr
; (us, fv_us) <- rnHsUpdProjs flds
; return ( mkExpandedExpr
(RecordUpd noExtField e (Right us))
(mkRecordDotUpd getField setField e us)
, plusFVs [fv_getField, fv_setField, fv_e, fv_us] )
}
rnExpr (ExprWithTySig _ expr pty)
= do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
rnExpr (HsIf _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
; let fvs_if = plusFVs [fvP, fvB1, fvB2]
rn_if = HsIf noExtField p' b1' b2'
; mb_ite <- lookupIfThenElse
; case mb_ite of
Nothing
-> return (rn_if, fvs_if)
Just ite_name
-> do { let ds_if = genHsApps ite_name [p', b1', b2']
fvs = plusFVs [fvs_if, unitFV ite_name]
; return (mkExpandedExpr rn_if ds_if, fvs) } }
rnExpr (HsMultiIf _ alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
; return (HsMultiIf noExtField alts', fvs) }
rnExpr (ArithSeq _ _ seq)
= do { opt_OverloadedLists <- xoptM 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 e@(HsStatic _ expr) = do
unlessXOptM LangExt.StaticPointers $
addErr $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Illegal static expression:" <+> ppr e)
2 (text "Use StaticPointers to enable this extension")
(expr',fvExpr) <- rnLExpr expr
stage <- getStage
case stage of
Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep
[ text "static forms cannot be used in splices:"
, nest 2 $ ppr e
]
_ -> return ()
mod <- getModule
let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
return (HsStatic fvExpr' expr', fvExpr)
rnExpr (HsProc x pat body)
= newArrowScope $
rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do
{ (body',fvBody) <- rnCmdTop body
; return (HsProc x pat' body', fvBody) }
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnSection section@(SectionR x op expr)
= do { (op', fvs_op) <- rnLExpr op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
; let rn_section = SectionR x op' expr'
ds_section = genHsApps rightSectionName [op',expr']
; return ( mkExpandedExpr rn_section ds_section
, fvs_op `plusFV` fvs_expr) }
rnSection section@(SectionL x expr op)
= do { (expr', fvs_expr) <- rnLExpr expr
; (op', fvs_op) <- rnLExpr op
; checkSectionPrec InfixL section op' expr'
; postfix_ops <- xoptM LangExt.PostfixOperators
; let rn_section = SectionL x expr' op'
ds_section
| postfix_ops = HsApp noAnn op' expr'
| otherwise = genHsApps leftSectionName
[wrapGenSpan $ HsApp noAnn op' expr']
; return ( mkExpandedExpr rn_section ds_section
, fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
rnCmdArgs [] = return ([], emptyFVs)
rnCmdArgs (arg:args)
= do { (arg',fvArg) <- rnCmdTop arg
; (args',fvArgs) <- rnCmdArgs args
; return (arg':args', fvArg `plusFV` fvArgs) }
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = wrapLocFstMA rnCmdTop'
where
rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
rnCmdTop' (HsCmdTop _ cmd)
= do { (cmd', fvCmd) <- rnLCmd cmd
; let cmd_names = [arrAName, composeAName, firstAName] ++
nameSetElemsStable (methodNamesCmd (unLoc 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 = wrapLocFstMA rnCmd
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd (HsCmdArrApp _ arrow arg ho rtl)
= do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdArrApp noExtField arrow' arg' ho rtl,
fvArrow `plusFV` fvArg) }
where
select_arrow_scope tc = case ho of
HsHigherOrderApp -> tc
HsFirstOrderApp -> escapeArrowScope tc
rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
= do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
; let L _ (HsVar _ (L _ op_name)) = op'
; (arg1',fv_arg1) <- rnCmdTop arg1
; (arg2',fv_arg2) <- rnCmdTop arg2
; fixity <- lookupFixityRn op_name
; final_e <- mkOpFormRn arg1' op' fixity arg2'
; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
rnCmd (HsCmdArrForm _ op f fixity cmds)
= do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
; (cmds',fvCmds) <- rnCmdArgs cmds
; return ( HsCmdArrForm noExtField op' f fixity cmds'
, fvOp `plusFV` fvCmds) }
rnCmd (HsCmdApp x fun arg)
= do { (fun',fvFun) <- rnLCmd fun
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
rnCmd (HsCmdLam _ matches)
= do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches
; return (HsCmdLam noExtField matches', fvMatch) }
rnCmd (HsCmdPar x lpar e rpar)
= do { (e', fvs_e) <- rnLCmd e
; return (HsCmdPar x lpar e' rpar, fvs_e) }
rnCmd (HsCmdCase _ expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
; return (HsCmdCase noExtField new_expr new_matches
, e_fvs `plusFV` ms_fvs) }
rnCmd (HsCmdLamCase x lc_variant matches)
= do { (new_matches, ms_fvs) <-
rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches
; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }
rnCmd (HsCmdIf _ _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
; mb_ite <- lookupIfThenElse
; let (ite, fvITE) = case mb_ite of
Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)
Nothing -> (NoSyntaxExprRn, emptyFVs)
; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
rnCmd (HsCmdLet _ tkLet binds tkIn cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
{ (cmd',fvExpr) <- rnLCmd cmd
; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }
rnCmd (HsCmdDo _ (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs))
; return ( HsCmdDo noExtField (L l stmts'), fvs ) }
type CmdNeeds = FreeVars
methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc
methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
= emptyFVs
methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
= unitFV appAName
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c
methodNamesCmd (HsCmdIf _ _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c
methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c
methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
methodNamesCmd (HsCmdCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
methodNamesCmd (HsCmdLamCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =
methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt {}) = emptyFVs
methodNamesStmt (ParStmt {}) = emptyFVs
methodNamesStmt (TransStmt {}) = emptyFVs
methodNamesStmt ApplicativeStmt{} = emptyFVs
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
rnArithSeq (From expr)
= do { (expr', fvExpr) <- rnLExpr expr
; return (From expr', fvExpr) }
rnArithSeq (FromThen expr1 expr2)
= do { (expr1', fvExpr1) <- rnLExpr expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromTo expr1 expr2)
= do { (expr1', fvExpr1) <- rnLExpr expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromThenTo expr1 expr2 expr3)
= do { (expr1', fvExpr1) <- rnLExpr expr1
; (expr2', fvExpr2) <- rnLExpr expr2
; (expr3', fvExpr3) <- rnLExpr expr3
; return (FromThenTo expr1' expr2' expr3',
plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
type AnnoBody body
= ( Outputable (body GhcPs)
, Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
)
rnStmts :: AnnoBody body
=> HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
rnStmts ctxt rnBody stmts thing_inside
= do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
; return ((map fst stmts', thing), fvs) }
postProcessStmtsForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo ctxt stmts
= do {
ado_is_on <- xoptM LangExt.ApplicativeDo
; let is_do_expr | DoExpr{} <- ctxt = True
| otherwise = 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
:: HsStmtContext GhcRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
rnStmtsWithFreeVars :: AnnoBody body
=> HsStmtContext GhcRn
-> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmtsWithFreeVars ctxt _ [] thing_inside
= do { checkEmptyStmts ctxt
; (thing, fvs) <- thing_inside []
; return (([], thing), fvs) }
rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside
=
do { ((stmts1, (stmts2, thing)), fvs)
<- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->
do { last_stmt' <- checkLastStmt mDoExpr last_stmt
; rnStmt mDoExpr rnBody last_stmt' thing_inside }
; return (((stmts1 ++ stmts2), thing), fvs) }
where
Just (all_but_last, last_stmt) = snocView stmts
rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
| null lstmts
= setSrcSpanA loc $
do { lstmt' <- checkLastStmt ctxt lstmt
; rnStmt ctxt rnBody lstmt' thing_inside }
| otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpanA loc $
do { checkStmt ctxt lstmt
; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
rnStmt :: AnnoBody body
=> HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> LStmt GhcPs (LocatedA (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
= do { (body', fv_expr) <- rnBody 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 ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside
= do { (body', fv_expr) <- rnBody 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 ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
; (fail_op, fvs2) <- monadFailOp pat ctxt
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')
; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside
= rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds')
; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)
, fvs) }
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside
= do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName
; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName
; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName
; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
, recS_mfix_fn = mfix_op
, recS_bind_fn = bind_op }
; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do
{ let bndrs = nameSetElemsStable $
foldr (unionNameSet . (\(ds,_,_,_) -> ds))
emptyNameSet
segs
; (thing, fvs_later) <- thing_inside 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 ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
= do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt 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 ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
, trS_using = using })) thing_inside
= do {
(using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) 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
ThenForm -> return (noExpr, emptyFVs)
_ -> lookupStmtNamePoly ctxt fmapName
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
`plusFV` fvs4 `plusFV` fvs5
bndr_map = used_bndrs `zip` 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) }
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
rnParallelStmts :: forall thing. HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rnParallelStmts ctxt return_op segs thing_inside
= do { orig_lcl_env <- getLocalRdrEnv
; rn_segs orig_lcl_env [] segs }
where
rn_segs :: LocalRdrEnv
-> [Name] -> [ParStmtBlock GhcPs GhcPs]
-> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
rn_segs _ bndrs_so_far []
= do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
; mapM_ dupErr dups
; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
; return (([], thing), fvs) }
rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnStmts ctxt rnExpr stmts $ \ bndrs ->
setLocalRdrEnv env $ do
{ ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
; return ((used_bndrs, segs', thing), fvs) }
; let seg' = ParStmtBlock x stmts' used_bndrs return_op
; return ((seg':segs', thing), fvs) }
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (NE.head vs)))
lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDoStmtName ctxt n
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupStmtName ctxt n
Just modName ->
first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName ctxt n
| rebindableContext ctxt
= lookupSyntax n
| otherwise
= return (mkRnSyntaxExpr n, emptyFVs)
lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly ctxt name
| rebindableContext ctxt
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fm <- lookupOccRn (nameRdrName name)
; return (HsVar noExtField (noLocA fm), unitFV fm) }
else not_rebindable }
| otherwise
= not_rebindable
where
not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)
rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext ctxt = case ctxt of
HsDoStmt flavour -> rebindableDoStmtContext flavour
ArrowExpr -> False
PatGuard {} -> False
ParStmtCtxt c -> rebindableContext c
TransStmtCtxt c -> rebindableContext c
rebindableDoStmtContext :: HsDoFlavour -> Bool
rebindableDoStmtContext flavour = case flavour of
ListComp -> False
DoExpr m -> isNothing m
MDoExpr m -> isNothing m
MonadComp -> True
GhciStmtCtxt -> True
type FwdRefs = NameSet
type Segment stmts = (Defs,
Uses,
FwdRefs,
stmts)
rnRecStmtsAndThen :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen ctxt rnBody s cont
= do {
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)
rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
implicit_uses = mkNameSet $ concatMap snd $ 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_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
rec_uses
; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
; return (res, fvs) }}
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities l =
foldr (\ s -> \acc -> case s of
(L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->
foldr (\ sig -> \ acc -> case sig of
(L loc (FixSig _ s)) -> (L loc s) : acc
_ -> acc) acc sigs
_ -> acc) [] 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 _ (L loc (BodyStmt _ body a b))
= return [(L loc (BodyStmt noExtField body a b), emptyFVs)]
rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
= return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
= do
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
return [(L loc (BindStmt noAnn pat' body), fv_pat)]
rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {})))
= failWith (badIpBinds (text "an mdo expression") binds)
rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))
= do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
return [(L loc (LetStmt noAnn (HsValBinds x binds')),
emptyFVs
)]
rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts }))
= rn_rec_stmts_lhs fix_env stmts
rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {}))
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
= panic "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 fix_env stmts
= do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls)
; checkDupNames boundNames
; return ls }
rn_rec_stmt :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _)
= do { (body', fv_expr) <- rnBody 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 ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _)
= do { (body', fvs) <- rnBody 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 ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
; (fail_op, fvs2) <- getMonadFailOp ctxt
; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt xbsrn pat' (L lb body')))] }
rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _)
= failWith (badIpBinds (text "an mdo expression") binds)
rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _)
= do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
; let fvs = allUses du_binds
; return [(duDefs du_binds, fvs, emptyNameSet,
L loc (LetStmt noAnn (HsValBinds x binds')))] }
rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)
= pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _)
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _)
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
rn_rec_stmts :: AnnoBody body =>
HsStmtContext GhcRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
rn_rec_stmts ctxt rnBody bndrs stmts
= do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts
; return (concat segs_s) }
segmentRecStmts :: AnnoBody body
=> SrcSpan -> HsStmtContext GhcRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> (FreeVars, Bool)
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later)
| null segs
= ([], final_fv_uses)
| HsDoStmt (MDoExpr _) <- ctxt
= segsToStmts empty_rec_stmt grouped_segs fvs_later
| otherwise
= ([ L (noAnnSrcSpan loc) $
empty_rec_stmt { recS_stmts = noLocA ss
, recS_later_ids = nameSetElemsStable final_fvs_later
, recS_rec_ids = nameSetElemsStable
(defs `intersectNameSet` uses) }]
, uses `plusFV` final_fv_uses)
where
(final_fv_uses, final_fvs_later)
| might_be_more_fvs_later
= (defs, defs)
| otherwise
= ( uses `plusFV` fvs_later
, defs `intersectNameSet` fvs_later )
(defs_s, uses_s, _, ss) = unzip4 segs
defs = plusFVs defs_s
uses = plusFVs uses_s
segs_w_fwd_refs = addFwdRefs segs
grouped_segs = glomSegments ctxt segs_w_fwd_refs
addFwdRefs :: [Segment a] -> [Segment a]
addFwdRefs segs
= fst (foldr mk_seg ([], emptyNameSet) segs)
where
mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
= (new_seg : segs, all_defs)
where
new_seg = (defs, uses, new_fwds, stmts)
all_defs = later_defs `unionNameSet` defs
new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
glomSegments :: HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
glomSegments _ [] = []
glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
= (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
where
segs' = glomSegments ctxt segs
(extras, others) = grab uses segs'
(ds, us, fs, ss) = unzip4 extras
seg_defs = plusFVs ds `plusFV` defs
seg_uses = plusFVs us `plusFV` uses
seg_fwds = plusFVs fs `plusFV` fwds
seg_stmts = stmt : concat ss
grab :: NameSet
-> [Segment a]
-> ([Segment a],
[Segment a])
grab uses dus
= (reverse yeses, reverse noes)
where
(noes, yeses) = span not_needed (reverse dus)
not_needed (defs,_,_,_) = disjointNameSet defs uses
segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-> FreeVars
-> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
segsToStmts _ [] fvs_later = ([], fvs_later)
segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
= assert (not (null ss))
(new_stmt : later_stmts, later_uses `plusFV` uses)
where
(later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
new_stmt | non_rec = head ss
| otherwise = L (getLoc (head ss)) rec_stmt
rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss
, recS_later_ids = nameSetElemsStable used_later
, recS_rec_ids = nameSetElemsStable fwds }
non_rec = isSingleton ss && isEmptyNameSet fwds
used_later = defs `intersectNameSet` later_uses
data MonadNames = MonadNames { return_name, pure_name :: Name }
instance Outputable MonadNames where
ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =
hcat
[text "MonadNames { return_name = "
,ppr return_name
,text ", pure_name = "
,ppr pure_name
,text "}"
]
rearrangeForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
rearrangeForApplicativeDo ctxt [(one,_)] = do
(return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let pure_expr = nl_HsVar pure_name
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
return $ case needJoin monad_names [one] (Just pure_expr) of
(False, one') -> (one', emptyNameSet)
(True, _) -> ([one], emptyNameSet)
rearrangeForApplicativeDo ctxt stmts0 = do
optimal_ado <- goptM Opt_OptimalApplicativeDo
let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
| otherwise = mkStmtTreeHeuristic stmts
traceRn "rearrangeForADo" (ppr stmt_tree)
(return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
where
(stmts,(last,last_fvs)) = findLast stmts0
findLast [] = error "findLast"
findLast [last] = ([],last)
findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
data StmtTree a
= StmtTreeOne a
| StmtTreeBind (StmtTree a) (StmtTree a)
| StmtTreeApplicative [StmtTree a]
instance Outputable a => Outputable (StmtTree a) where
ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x)
ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind")
2 (sep [ppr x, ppr y]))
ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
2 (vcat (map ppr xs)))
flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree t = go t []
where
go (StmtTreeOne a) as = a : as
go (StmtTreeBind l r) as = go l (go r as)
go (StmtTreeApplicative ts) as = foldr go as ts
type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
type Cost = Int
mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeHeuristic [one] = StmtTreeOne one
mkStmtTreeHeuristic stmts =
case segments stmts of
[one] -> split one
segs -> StmtTreeApplicative (map split segs)
where
split [one] = StmtTreeOne one
split stmts =
StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
where (before, after) = splitSegment stmts
mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
mkStmtTreeOptimal stmts =
assert (not (null stmts)) $
fst (arr ! (0,n))
where
n = length stmts 1
stmt_arr = listArray (0,n) stmts
arr :: Array (Int,Int) (ExprStmtTree, Cost)
arr = array ((0,0),(n,n))
[ ((lo,hi), tree lo hi)
| lo <- [0..n]
, hi <- [lo..n] ]
tree lo hi
| hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
| otherwise =
case segments [ stmt_arr ! i | i <- [lo..hi] ] of
[] -> panic "mkStmtTree"
[_one] -> split lo hi
segs -> (StmtTreeApplicative trees, maximum costs)
where
bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo1) segs
(trees,costs) = unzip (map (uncurry split) (tail bounds))
split :: Int -> Int -> (ExprStmtTree, Cost)
split lo hi
| hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
| otherwise = (StmtTreeBind before after, c1+c2)
where
((before,c1),(after,c2))
| hi lo == 1
= ((StmtTreeOne (stmt_arr ! lo), 1),
(StmtTreeOne (stmt_arr ! hi), 1))
| left_cost < right_cost
= ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
| left_cost > right_cost
= ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
| otherwise = minimumBy (comparing cost) alternatives
where
(left, left_cost) = arr ! (lo,hi1)
(right, right_cost) = arr ! (lo+1,hi)
cost ((_,c1),(_,c2)) = c1 + c2
alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
| k <- [lo .. hi1] ]
stmtTreeToStmts
:: MonadNames
-> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ( [ExprLStmt GhcRn]
, FreeVars )
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))
tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing
= mkApplicativeStmt ctxt [ApplicativeArgOne
{ xarg_app_arg_one = xbsrn_failOp xbs
, app_arg_pattern = pat
, arg_expr = rhs
, is_body_stmt = False
}]
False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail Nothing
= mkApplicativeStmt ctxt
[ApplicativeArgOne
{ xarg_app_arg_one = Nothing
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
}] False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))
tail _tail_fvs = do
(pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
return $ case needJoin monad_names tail (Just pure_expr) of
(False, tail') -> (let_stmt : tail', emptyNameSet)
(True, _) -> (let_stmt : tail, emptyNameSet)
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
(stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
(stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
return (stmts2, fvs1 `plusFV` fvs2)
stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
dflags <- getDynFlags
let (stmts', fvss) = unzip pairs
let (need_join, tail') =
if any (hasRefutablePattern dflags) 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 _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
= return (ApplicativeArgOne
{ xarg_app_arg_one = xbsrn_failOp xbs
, app_arg_pattern = pat
, arg_expr = exp
, is_body_stmt = False
}, emptyFVs)
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
return (ApplicativeArgOne
{ xarg_app_arg_one = Nothing
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
`intersectNameSet` tail_fvs
pvars = nameSetElemsStable pvarset
pat = mkBigLHsVarPatTup pvars
tup = mkBigLHsVarTup pvars noExtField
(stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
(mb_ret, fvs1) <-
if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
(ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName
let expr = HsApp noComments (noLocA ret) 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 stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
where
allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
merge [] = []
merge (seg : segs)
= case rest of
[] -> [(seg,all_lets)]
((s,s_lets):ss) | all_lets || s_lets
-> (seg ++ s, all_lets && s_lets) : ss
_otherwise -> (seg,all_lets) : rest
where
rest = merge segs
all_lets = all (isLetStmt . fst) seg
walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
walk [] = []
walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
where (seg,rest) = chunter fvs' stmts
(_, fvs') = stmtRefs stmt fvs
chunter _ [] = ([], [])
chunter vars ((stmt,fvs) : rest)
| not (isEmptyNameSet vars)
|| isStrictPatternBind stmt
= ((stmt,fvs) : chunk, rest')
where (chunk,rest') = chunter vars' rest
(pvars, evars) = stmtRefs stmt fvs
vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
chunter _ rest = ([], rest)
stmtRefs stmt fvs
| isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
| otherwise = (pvars, fvs')
where fvs' = fvs `intersectNameSet` allvars
pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
isStrictPatternBind _ = False
isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
isStrictPattern (L loc pat) =
case pat of
WildPat{} -> False
VarPat{} -> False
LazyPat{} -> False
AsPat _ _ p -> isStrictPattern p
ParPat _ _ p _ -> isStrictPattern p
ViewPat _ _ p -> isStrictPattern p
SigPat _ p _ -> isStrictPattern p
BangPat{} -> True
ListPat{} -> True
TuplePat{} -> True
SumPat{} -> True
ConPat{} -> True
LitPat{} -> True
NPat{} -> True
NPlusKPat{} -> True
SplicePat{} -> True
XPat ext -> case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> dataConCantHappen ext
#endif
GhcRn
| HsPatExpanded _ p <- ext
-> isStrictPattern (L loc p)
GhcTc -> case ext of
ExpansionPat _ p -> isStrictPattern (L loc p)
CoPat {} -> panic "isStrictPattern: CoPat"
hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
, is_body_stmt = False}) =
not (isIrrefutableHsPat dflags pat)
hasRefutablePattern _ _ = False
isLetStmt :: LStmt (GhcPass a) b -> Bool
isLetStmt (L _ LetStmt{}) = True
isLetStmt _ = False
splitSegment
:: [(ExprLStmt GhcRn, FreeVars)]
-> ( [(ExprLStmt GhcRn, FreeVars)]
, [(ExprLStmt GhcRn, FreeVars)] )
splitSegment [one,two] = ([one],[two])
splitSegment stmts
| Just (lets,binds,rest) <- slurpIndependentStmts stmts
= if not (null lets)
then (lets, binds++rest)
else (lets++binds, rest)
| otherwise
= case stmts of
(x:xs) -> ([x],xs)
_other -> (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 stmts = go [] [] emptyNameSet stmts
where
go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
| disjointNameSet bndrs fvs && not (isStrictPattern pat)
= go lets ((L loc (BindStmt xbs pat body), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)
go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)
| disjointNameSet bndrs fvs
= go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest
go _ [] _ _ = Nothing
go _ [_] _ _ = Nothing
go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
mkApplicativeStmt
:: HsDoFlavour
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt ctxt args need_join body_stmts
= do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) 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)
; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
(zip (fmap_op : repeat ap_op) args)
mb_join
; return ( applicative_stmt : body_stmts
, fvs1 `plusFV` fvs2 `plusFV` fvs3) }
needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> Maybe (HsExpr GhcRn)
-> (Bool, [ExprLStmt GhcRn])
needJoin _monad_names [] _mb_pure = (False, [])
needJoin monad_names [L loc (LastStmt _ e _ t)] mb_pure
| Just (arg, noret) <- isReturnApp monad_names e mb_pure =
(False, [L loc (LastStmt noExtField arg noret t)])
needJoin _monad_names stmts _mb_pure = (True, stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe (HsExpr GhcRn)
-> Maybe (LHsExpr GhcRn, Maybe Bool)
isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure =
isReturnApp monad_names expr mb_pure
isReturnApp monad_names (L loc e) mb_pure = case e of
OpApp x l op r
| Just pure_expr <- mb_pure, is_return l, is_dollar op ->
Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)
| is_return l, is_dollar op -> Just (r, Just True)
HsApp x f arg
| Just pure_expr <- mb_pure, is_return f ->
Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)
| is_return f -> Just (arg, Just False)
_otherwise -> Nothing
where
is_var f (L _ (HsPar _ _ e _)) = is_var f e
is_var f (L _ (HsAppType _ e _)) = is_var f e
is_var f (L _ (HsVar _ (L _ r))) = f r
is_var _ _ = False
is_return = is_var (\n -> n == return_name monad_names
|| n == pure_name monad_names)
to_pure (L loc _) pure_expr = L loc pure_expr
is_dollar = is_var (`hasKey` dollarIdKey)
checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
checkEmptyStmts ctxt
= unless (okEmpty ctxt) (addErr (emptyErr ctxt))
okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = True
okEmpty _ = False
emptyErr :: HsStmtContext GhcRn -> TcRnMessage
emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
text "Empty statement group in parallel comprehension"
emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $
text "Empty statement group preceding 'group' or 'then'"
emptyErr ctxt@(HsDoStmt _) = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $
text "Empty" <+> pprStmtContext ctxt
emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $
text "Empty" <+> pprStmtContext ctxt
checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
= case ctxt of
HsDoStmt ListComp -> check_comp
HsDoStmt MonadComp -> check_comp
HsDoStmt DoExpr{} -> check_do
HsDoStmt MDoExpr{} -> check_do
ArrowExpr -> check_do
_ -> check_other
where
check_do
= case stmt of
BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
LastStmt {} -> return lstmt
_ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(hang last_error 2 (ppr stmt))
; return lstmt }
last_error = (text "The last statement in" <+> pprAStmtContext ctxt
<+> text "must be an expression")
check_comp
= case stmt of
LastStmt {} -> return lstmt
_ -> pprPanic "checkLastStmt" (ppr lstmt)
check_other
= do { checkStmt ctxt lstmt; return lstmt }
checkStmt :: HsStmtContext GhcRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM ()
checkStmt ctxt (L _ stmt)
= do { dflags <- getDynFlags
; case okStmt dflags ctxt stmt of
IsValid -> return ()
NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) }
where
msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
, text "in" <+> pprAStmtContext ctxt ]
pprStmtCat :: Stmt (GhcPass a) body -> SDoc
pprStmtCat (TransStmt {}) = text "transform"
pprStmtCat (LastStmt {}) = text "return expression"
pprStmtCat (BodyStmt {}) = text "body"
pprStmtCat (BindStmt {}) = text "binding"
pprStmtCat (LetStmt {}) = text "let"
pprStmtCat (RecStmt {}) = text "rec"
pprStmtCat (ParStmt {}) = text "parallel"
pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
emptyInvalid :: Validity
emptyInvalid = NotValid Outputable.empty
okStmt, okDoStmt, okCompStmt, okParStmt
:: DynFlags -> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okStmt dflags ctxt stmt
= case ctxt of
PatGuard {} -> okPatGuardStmt stmt
ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
HsDoStmt flavour -> okDoFlavourStmt dflags flavour ctxt stmt
ArrowExpr -> okDoStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
okDoFlavourStmt
:: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
DoExpr{} -> okDoStmt dflags ctxt stmt
MDoExpr{} -> okDoStmt dflags ctxt stmt
GhciStmtCtxt -> okDoStmt dflags ctxt stmt
ListComp -> okCompStmt dflags ctxt stmt
MonadComp -> okCompStmt dflags ctxt stmt
okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okPatGuardStmt stmt
= case stmt of
BodyStmt {} -> IsValid
BindStmt {} -> IsValid
LetStmt {} -> IsValid
_ -> emptyInvalid
okParStmt dflags ctxt stmt
= case stmt of
LetStmt _ (HsIPBinds {}) -> emptyInvalid
_ -> okStmt dflags ctxt stmt
okDoStmt dflags ctxt stmt
= case stmt of
RecStmt {}
| LangExt.RecursiveDo `xopt` dflags -> IsValid
| ArrowExpr <- ctxt -> IsValid
| otherwise -> NotValid (text "Use RecursiveDo")
BindStmt {} -> IsValid
LetStmt {} -> IsValid
BodyStmt {} -> IsValid
_ -> emptyInvalid
okCompStmt dflags _ stmt
= case stmt of
BindStmt {} -> IsValid
LetStmt {} -> IsValid
BodyStmt {} -> IsValid
ParStmt {}
| LangExt.ParallelListComp `xopt` dflags -> IsValid
| otherwise -> NotValid (text "Use ParallelListComp")
TransStmt {}
| LangExt.TransformListComp `xopt` dflags -> IsValid
| otherwise -> NotValid (text "Use TransformListComp")
RecStmt {} -> emptyInvalid
LastStmt {} -> emptyInvalid
ApplicativeStmt {} -> emptyInvalid
checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
checkTupleSection args
= do { tuple_section <- xoptM LangExt.TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg :: TcRnMessage
msg = TcRnUnknownMessage $ mkPlainError noHints $
text "Illegal tuple section: use TupleSections"
sectionErr :: HsExpr GhcPs -> TcRnMessage
sectionErr expr
= TcRnUnknownMessage $ mkPlainError noHints $
hang (text "A section must be enclosed in parentheses")
2 (text "thus:" <+> (parens (ppr expr)))
badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage
badIpBinds what binds
= TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Implicit-parameter bindings illegal in" <+> what)
2 (ppr binds)
monadFailOp :: LPat GhcPs
-> HsStmtContext GhcRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
dflags <- getDynFlags
if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
| not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
| otherwise -> getMonadFailOp ctxt
getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars)
getMonadFailOp ctxt
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; return (Just fail, fvs)
}
where
isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)
reallyGetMonadFailOp rebindableSyntax overloadedStrings
| (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
(failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
let arg_lit = mkVarOcc "arg"
arg_name <- newSysName arg_lit
let arg_syn_expr = nlHsVar arg_name
body :: LHsExpr GhcRn =
nlHsApp (noLocA failExpr)
(nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
| otherwise = lookupQualifiedDo ctxt failMName
mkExpandedExpr
:: HsExpr GhcRn
-> HsExpr GhcRn
-> HsExpr GhcRn
mkExpandedExpr a b = XExpr (HsExpanded a b)
mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
mkSetField set_field a (L _ field) b =
genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b
mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
mkGet get_field l@(r : _) (L _ field) =
wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
mkGet _ [] _ = panic "mkGet : The impossible has happened!"
mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn
mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields
where
f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
= let {
; flds = map (fmap (unLoc . dfoLabel)) flds'
; final = last flds
; fields = init flds
; getters = \a -> foldl' (mkGet get_field) [a] fields
; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a))
}
in (\a -> foldl' (mkSet set_field) arg (zips a))
mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn
mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates
where
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)
rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
rnHsUpdProjs us = do
(u, fvs) <- unzip <$> mapM rnRecUpdProj us
pure (u, plusFVs fvs)
where
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
rnRecUpdProj (L l (HsFieldBind _ fs arg pun))
= do { (arg, fv) <- rnLExpr arg
; return $
(L l (HsFieldBind {
hfbAnn = noAnn
, hfbLHS = fmap rnFieldLabelStrings fs
, hfbRHS = arg
, hfbPun = pun}), fv ) }