module RnExpr (
rnLExpr, rnExpr, rnStmts
) where
#include "HsVersions.h"
import GhcPrelude
import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import Module ( getModule )
import RnEnv
import RnFixity
import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
, bindLocalNames
, mapMaybeFvRn, mapFvRn
, warnUnusedLocalBinds )
import RnUnbound ( reportUnboundName )
import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes
import RnPat
import DynFlags
import PrelNames
import BasicTypes
import Name
import NameSet
import RdrName
import UniqSet
import Data.List
import Util
import ListSetOps ( removeDups )
import ErrUtils
import Outputable
import SrcLoc
import FastString
import Control.Monad
import TysWiredIn ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
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 = wrapLocFstM rnExpr
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
; return (HsVar noExt (L l name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v
= do { if isUnqual v
then
do { let occ = rdrNameOcc v
; uv <- if startsWithUnderscore occ
then return (TrueExprHole occ)
else OutOfScope occ <$> getGlobalRdrEnv
; return (HsUnboundVar noExt uv, emptyFVs) }
else
do { n <- reportUnboundName v
; return (HsVar noExt (noLoc n), emptyFVs) } }
rnExpr (HsVar _ (L l v))
= do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
; case mb_name of {
Nothing -> rnUnboundVar v ;
Just (Left name)
| name == nilDataConName
-> rnExpr (ExplicitList noExt Nothing [])
| otherwise
-> finishHsVar (L l name) ;
Just (Right [s]) ->
return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
Just (Right fs@(_:_:_)) ->
return ( HsRecFld noExt (Ambiguous noExt (L l v))
, mkFVs fs);
Just (Right []) -> panic "runExpr/HsVar" } }
rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs)
rnExpr (HsOverLabel x _ v)
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
else return (HsOverLabel x Nothing v, emptyFVs) }
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 x (noLoc neg) (noLoc (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 arg fun)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
; return (HsAppType arg' fun', 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 _ (HsRecFld _ f) -> lookupFieldFixityRn f
_ -> return (Fixity NoSourceText minPrecedence InfixL)
; final_e <- mkOpAppRn 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) <- lookupSyntaxName negateName
; final_e <- mkNegAppRn e' neg_name
; return (final_e, fv_e `plusFV` fv_neg) }
rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
rnExpr (HsPar x (L loc (section@(SectionL {}))))
= do { (section', fvs) <- rnSection section
; return (HsPar x (L loc section'), fvs) }
rnExpr (HsPar x (L loc (section@(SectionR {}))))
= do { (section', fvs) <- rnSection section
; return (HsPar x (L loc section'), fvs) }
rnExpr (HsPar x e)
= do { (e', fvs_e) <- rnLExpr e
; return (HsPar x e', fvs_e) }
rnExpr expr@(SectionL {})
= do { addErr (sectionErr expr); rnSection expr }
rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr }
rnExpr (HsCoreAnn x src ann expr)
= do { (expr', fvs_expr) <- rnLExpr expr
; return (HsCoreAnn x src ann expr', fvs_expr) }
rnExpr (HsSCC x src lbl expr)
= do { (expr', fvs_expr) <- rnLExpr expr
; return (HsSCC x src lbl expr', fvs_expr) }
rnExpr (HsTickPragma x src info srcInfo expr)
= do { (expr', fvs_expr) <- rnLExpr expr
; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
; return (HsLam x matches', fvMatch) }
rnExpr (HsLamCase x matches)
= do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
; return (HsLamCase x matches', fvs_ms) }
rnExpr (HsCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnExpr (HsLet x (L l binds) expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
{ (expr',fvExpr) <- rnLExpr expr
; return (HsLet x (L l binds') expr', fvExpr) }
rnExpr (HsDo x do_or_lc (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmtsWithPostProcessing do_or_lc rnLExpr
postProcessStmtsForApplicativeDo stmts
(\ _ -> return ((), emptyFVs))
; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
rnExpr (ExplicitList x _ exps)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (exps', fvs) <- rnExprs exps
; if opt_OverloadedLists
then do {
; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
; return (ExplicitList x (Just from_list_n_name) exps'
, fvs `plusFV` fvs') }
else
return (ExplicitList x Nothing exps', fvs) }
rnExpr (ExplicitTuple x tup_args boxity)
= do { checkTupleSection tup_args
; checkTupSize (length tup_args)
; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
where
rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
; return (L l (Present x e'), fvs) }
rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
, emptyFVs)
rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
rnExpr (ExplicitSum x alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
; return (ExplicitSum x alt arity expr', fvs) }
rnExpr (RecordCon { rcon_con_name = con_id
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
= do { con_lname@(L _ con_name) <- lookupLocatedOccRn 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 = noExt
, rcon_con_name = con_lname, rcon_flds = rec_binds' }
, fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
where
mk_hs_var l n = HsVar noExt (L l n)
rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
= do { (expr', fvExpr) <- rnLExpr expr
; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
, rupd_flds = rbinds' }
, fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig pty expr)
= do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
rnExpr (HsIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
; (mb_ite, fvITE) <- lookupIfThenElse
; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnExpr (HsMultiIf x alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
; return (HsMultiIf x alts', fvs) }
rnExpr (ArithSeq x _ seq)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
; if opt_OverloadedLists
then do {
; (from_list_name, fvs') <- lookupSyntaxName fromListName
; return (ArithSeq x (Just from_list_name) new_seq
, fvs `plusFV` fvs') }
else
return (ArithSeq x Nothing new_seq, fvs) }
rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs)
rnExpr e@(EAsPat {})
= do { opt_TypeApplications <- xoptM LangExt.TypeApplications
; let msg | opt_TypeApplications
= "Type application syntax requires a space before '@'"
| otherwise
= "Did you mean to enable TypeApplications?"
; patSynErr e (text msg)
}
rnExpr e@(EViewPat {}) = patSynErr e empty
rnExpr e@(ELazyPat {}) = patSynErr e empty
rnExpr e@(HsStatic _ expr) = do
unlessXOptM LangExt.StaticPointers $
addErr $ 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 $ 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 ProcExpr pat $ \ pat' -> do
{ (body',fvBody) <- rnCmdTop body
; return (HsProc x pat' body', fvBody) }
rnExpr e@(HsArrApp {}) = arrowFail e
rnExpr e@(HsArrForm {}) = arrowFail e
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
arrowFail e
= do { addErr (vcat [ text "Arrow command found where an expression was expected:"
, nest 2 (ppr e) ])
; return (hsHoleExpr, emptyFVs) }
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'
; return (SectionR x op' expr', 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'
; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
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 = wrapLocFstM rnCmdTop'
where
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) }
rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = wrapLocFstM rnCmd
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
rnCmd (HsCmdArrApp x arrow arg ho rtl)
= do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
; (arg',fvArg) <- rnLExpr arg
; return (HsCmdArrApp x 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 x op f fixity cmds)
= do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
; (cmds',fvCmds) <- rnCmdArgs cmds
; return (HsCmdArrForm x 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 x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
; return (HsCmdLam x matches', fvMatch) }
rnCmd (HsCmdPar x e)
= do { (e', fvs_e) <- rnLCmd e
; return (HsCmdPar x e', fvs_e) }
rnCmd (HsCmdCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnCmd (HsCmdIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
; (mb_ite, fvITE) <- lookupIfThenElse
; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
rnCmd (HsCmdLet x (L l binds) cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
{ (cmd',fvExpr) <- rnLCmd cmd
; return (HsCmdLet x (L l binds') cmd', fvExpr) }
rnCmd (HsCmdDo x (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
; return ( HsCmdDo x (L l stmts'), fvs ) }
rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd)
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 (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
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 (XCmd {}) = panic "methodNamesCmd"
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
do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
methodNamesLStmt :: Located (StmtLR 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 = stmts }) =
methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt {}) = emptyFVs
methodNamesStmt (ParStmt {}) = emptyFVs
methodNamesStmt (TransStmt {}) = emptyFVs
methodNamesStmt ApplicativeStmt{} = emptyFVs
methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
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]) }
rnStmts :: Outputable (body GhcPs)
=> HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
rnStmtsWithPostProcessing
:: Outputable (body GhcPs)
=> HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> (HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
= do { ((stmts', thing), fvs) <-
rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
; (pp_stmts, fvs') <- ppStmts ctxt stmts'
; return ((pp_stmts, thing), fvs `plusFV` fvs')
}
postProcessStmtsForApplicativeDo
:: HsStmtContext Name
-> [(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
; if ado_is_on && is_do_expr
then do { traceRn "ppsfa" (ppr stmts)
; rearrangeForApplicativeDo ctxt stmts }
else noPostProcessStmts ctxt stmts }
noPostProcessStmts
:: HsStmtContext Name
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
rnStmtsWithFreeVars :: Outputable (body GhcPs)
=> HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmtsWithFreeVars ctxt _ [] thing_inside
= do { checkEmptyStmts ctxt
; (thing, fvs) <- thing_inside []
; return (([], thing), fvs) }
rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside
=
do { ((stmts1, (stmts2, thing)), fvs)
<- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt 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
= setSrcSpan loc $
do { lstmt' <- checkLastStmt ctxt lstmt
; rnStmt ctxt rnBody lstmt' thing_inside }
| otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan 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 :: Outputable (body GhcPs)
=> HsStmtContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LStmt GhcPs (Located (body GhcPs))
-> ([Name] -> RnM (thing, FreeVars))
-> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
, FreeVars)
rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
; (thing, fvs3) <- thing_inside []
; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
, thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (then_op, fvs1) <- lookupStmtName ctxt thenMName
; (guard_op, fvs2) <- if isListCompExpr ctxt
then lookupStmtName ctxt guardMName
else return (noSyntaxExpr, emptyFVs)
; (thing, fvs3) <- thing_inside []
; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
, thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
; let getFailFunction
| isIrrefutableHsPat pat
= return (noSyntaxExpr, emptyFVs)
| not (isMonadFailStmtContext ctxt)
= return (noSyntaxExpr, emptyFVs)
| xMonadFailEnabled = lookupSyntaxName failMName
| otherwise = lookupSyntaxName failMName_preMFP
; (fail_op, fvs2) <- getFailFunction
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
, fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
= do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
, fvs) } }
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
= do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
, recS_mfix_fn = mfix_op
, recS_bind_fn = bind_op }
; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
{ let bndrs = nameSetElemsStable $
foldr (unionNameSet . (\(ds,_,_,_) -> ds))
emptyNameSet
segs
; (thing, fvs_later) <- thing_inside bndrs
; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
; 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 noExt 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) rnLExpr 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 = noExt
, 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"
rnStmt _ _ (L _ XStmtLR{}) _ =
panic "rnStmt: XStmtLR"
rnParallelStmts :: forall thing. HsStmtContext Name
-> 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 rnLExpr 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) }
rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (NE.head vs)))
lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupStmtName ctxt n
| rebindableContext ctxt
= lookupSyntaxName n
| otherwise
= return (mkRnSyntaxExpr n, emptyFVs)
lookupStmtNamePoly :: HsStmtContext Name -> 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 noExt (noLoc fm), unitFV fm) }
else not_rebindable }
| otherwise
= not_rebindable
where
not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
rebindableContext :: HsStmtContext Name -> Bool
rebindableContext ctxt = case ctxt of
ListComp -> False
ArrowExpr -> False
PatGuard {} -> False
DoExpr -> True
MDoExpr -> True
MonadComp -> True
GhciStmtCtxt -> True
ParStmtCtxt c -> rebindableContext c
TransStmtCtxt c -> rebindableContext c
type FwdRefs = NameSet
type Segment stmts = (Defs,
Uses,
FwdRefs,
stmts)
rnRecStmtsAndThen :: Outputable (body GhcPs) =>
(Located (body GhcPs)
-> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnRecStmtsAndThen rnBody s cont
= do {
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
; bindLocalNamesFV bound_names $
addLocalFixities fix_env bound_names $ do
{ segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
; (res, fvs) <- cont segs
; 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 _ (L _ (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 :: Outputable body => MiniFixityEnv
-> LStmt GhcPs body
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
= return [(L loc (BodyStmt noExt body a b), emptyFVs)]
rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
= return [(L loc (LastStmt noExt body noret a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
= do
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
= failWith (badIpBinds (text "an mdo expression") binds)
rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
= do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
emptyFVs
)]
rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = 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 _ (L _ (EmptyLocalBinds _))))
= panic "rn_rec_stmt LetStmt EmptyLocalBinds"
rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
= panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
rn_rec_stmt_lhs _ (L _ (XStmtLR _))
= panic "rn_rec_stmt XStmtLR"
rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
-> [LStmt GhcPs body]
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
rn_rec_stmts_lhs fix_env stmts
= do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
; let boundNames = collectLStmtsBinders (map fst ls)
; checkDupNames boundNames
; return ls }
rn_rec_stmt :: (Outputable (body GhcPs)) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
= do { (body', fv_expr) <- rnBody body
; (ret_op, fvs1) <- lookupSyntaxName returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
L loc (LastStmt noExt body' noret ret_op))] }
rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
= do { (body', fvs) <- rnBody body
; (then_op, fvs1) <- lookupSyntaxName thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
; let failFunction | xMonadFailEnabled = failMName
| otherwise = failMName_preMFP
; (fail_op, fvs2) <- lookupSyntaxName failFunction
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt noExt pat' body' bind_op fail_op))] }
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (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 noExt (L l (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 _ (L _ (XHsLocalBindsLR _))), _)
= panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
= pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
rn_rec_stmts :: Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
rn_rec_stmts rnBody bndrs stmts
= do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
; return (concat segs_s) }
segmentRecStmts :: SrcSpan -> HsStmtContext Name
-> Stmt GhcRn body
-> [Segment (LStmt GhcRn body)] -> FreeVars
-> ([LStmt GhcRn body], FreeVars)
segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
| null segs
= ([], fvs_later)
| MDoExpr <- ctxt
= segsToStmts empty_rec_stmt grouped_segs fvs_later
| otherwise
= ([ L loc $
empty_rec_stmt { recS_stmts = ss
, recS_later_ids = nameSetElemsStable
(defs `intersectNameSet` fvs_later)
, recS_rec_ids = nameSetElemsStable
(defs `intersectNameSet` uses) }]
, uses `plusFV` fvs_later)
where
(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 Name
-> [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,_,_,_) = not (intersectsNameSet defs uses)
segsToStmts :: Stmt GhcRn body
-> [Segment [LStmt GhcRn body]]
-> FreeVars
-> ([LStmt GhcRn body], 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 = 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 }
rearrangeForApplicativeDo
:: HsStmtContext Name
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
rearrangeForApplicativeDo _ [(one,_)] = return ([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 <- lookupSyntaxName' returnMName
pure_name <- lookupSyntaxName' 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
-> HsStmtContext Name
-> ExprStmtTree
-> [ExprLStmt GhcRn]
-> FreeVars
-> RnM ( [ExprLStmt GhcRn]
, FreeVars )
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
[ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
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
let (stmts', fvss) = unzip pairs
let (need_join, tail') = needJoin monad_names tail
(stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss))
where
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
= return (ApplicativeArgOne noExt pat exp False, emptyFVs)
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
`intersectNameSet` tail_fvs
pvars = nameSetElemsStable pvarset
pat = mkBigLHsVarPatTup pvars
tup = mkBigLHsVarTup pvars
(stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
(mb_ret, fvs1) <-
if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName
return (HsApp noExt (noLoc ret) tup, fvs)
return ( ApplicativeArgMany noExt stmts' mb_ret pat
, 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.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 (unLoc stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
isStrictPatternBind _ = False
isStrictPattern :: LPat id -> Bool
isStrictPattern (L _ 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
ConPatIn{} -> True
ConPatOut{} -> True
LitPat{} -> True
NPat{} -> True
NPlusKPat{} -> True
SplicePat{} -> True
_otherwise -> panic "isStrictPattern"
isLetStmt :: LStmt 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 (Located (body GhcRn)), FreeVars)]
-> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
, [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
, [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
where
go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
= go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs)
= go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
go _ [] _ _ = Nothing
go _ [_] _ _ = Nothing
go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
mkApplicativeStmt
:: HsStmtContext Name
-> [ApplicativeArg GhcRn]
-> Bool
-> [ExprLStmt GhcRn]
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt ctxt args need_join body_stmts
= do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
; (ap_op, fvs2) <- lookupStmtName ctxt apAName
; (mb_join, fvs3) <-
if need_join then
do { (join_op, fvs) <- lookupStmtName ctxt joinMName
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
; let applicative_stmt = noLoc $ ApplicativeStmt noExt
(zip (fmap_op : repeat ap_op) args)
mb_join
; return ( applicative_stmt : body_stmts
, fvs1 `plusFV` fvs2 `plusFV` fvs3) }
needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> (Bool, [ExprLStmt GhcRn])
needJoin _monad_names [] = (False, [])
needJoin monad_names [L loc (LastStmt _ e _ t)]
| Just arg <- isReturnApp monad_names e =
(False, [L loc (LastStmt noExt arg True t)])
needJoin _monad_names stmts = (True, stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe (LHsExpr GhcRn)
isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
isReturnApp monad_names (L _ e) = case e of
OpApp _ l op r | is_return l, is_dollar op -> Just r
HsApp _ f arg | is_return f -> Just arg
_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)
is_dollar = is_var (`hasKey` dollarIdKey)
checkEmptyStmts :: HsStmtContext Name -> RnM ()
checkEmptyStmts ctxt
= unless (okEmpty ctxt) (addErr (emptyErr ctxt))
okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = True
okEmpty _ = False
emptyErr :: HsStmtContext Name -> SDoc
emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
= case ctxt of
ListComp -> check_comp
MonadComp -> check_comp
ArrowExpr -> check_do
DoExpr -> check_do
MDoExpr -> check_do
_ -> check_other
where
check_do
= case stmt of
BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
LastStmt {} -> return lstmt
_ -> do { addErr (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 Name
-> LStmt GhcPs (Located (body GhcPs))
-> RnM ()
checkStmt ctxt (L _ stmt)
= do { dflags <- getDynFlags
; case okStmt dflags ctxt stmt of
IsValid -> return ()
NotValid extra -> addErr (msg $$ extra) }
where
msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
, text "in" <+> pprAStmtContext ctxt ]
pprStmtCat :: Stmt 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"
pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR"
emptyInvalid :: Validity
emptyInvalid = NotValid Outputable.empty
okStmt, okDoStmt, okCompStmt, okParStmt
:: DynFlags -> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs)) -> Validity
okStmt dflags ctxt stmt
= case ctxt of
PatGuard {} -> okPatGuardStmt stmt
ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
DoExpr -> okDoStmt dflags ctxt stmt
MDoExpr -> okDoStmt dflags ctxt stmt
ArrowExpr -> okDoStmt dflags ctxt stmt
GhciStmtCtxt -> okDoStmt dflags ctxt stmt
ListComp -> okCompStmt dflags ctxt stmt
MonadComp -> okCompStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
okPatGuardStmt stmt
= case stmt of
BodyStmt {} -> IsValid
BindStmt {} -> IsValid
LetStmt {} -> IsValid
_ -> emptyInvalid
okParStmt dflags ctxt stmt
= case stmt of
LetStmt _ (L _ (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
XStmtLR{} -> panic "okCompStmt"
checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
checkTupleSection args
= do { tuple_section <- xoptM LangExt.TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg = text "Illegal tuple section: use TupleSections"
sectionErr :: HsExpr GhcPs -> SDoc
sectionErr expr
= hang (text "A section must be enclosed in parentheses")
2 (text "thus:" <+> (parens (ppr expr)))
patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
nest 4 (ppr e)] $$
explanation)
; return (EWildPat noExt, emptyFVs) }
badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds
= hang (text "Implicit-parameter bindings illegal in" <+> what)
2 (ppr binds)