diff options
Diffstat (limited to 'compiler/rename/RnExpr.hs')
| -rw-r--r-- | compiler/rename/RnExpr.hs | 226 |
1 files changed, 115 insertions, 111 deletions
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 027f6dc178..e1a314f029 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -13,6 +13,7 @@ free variables. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} module RnExpr ( rnLExpr, rnExpr, rnStmts @@ -65,7 +66,7 @@ import Data.Array ************************************************************************ -} -rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) @@ -79,12 +80,12 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Variables. We look up the variable and return the resulting name. -rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) rnLExpr = wrapLocFstM rnExpr -rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) +finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) @@ -93,7 +94,7 @@ finishHsVar (L l name) checkThLocalName name ; return (HsVar (L l name), unitFV name) } -rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) +rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v = do { if isUnqual v then -- Treat this as a "hole" @@ -145,11 +146,11 @@ rnExpr (HsLit lit@(HsString src s)) rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) else do { ; rnLit lit - ; return (HsLit lit, emptyFVs) } } + ; return (HsLit (convertLit lit), emptyFVs) } } rnExpr (HsLit lit) = do { rnLit lit - ; return (HsLit lit, emptyFVs) } + ; return (HsLit (convertLit lit), emptyFVs) } rnExpr (HsOverLit lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] @@ -409,7 +410,7 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) hsHoleExpr :: HsExpr id hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) -arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +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) ]) @@ -419,7 +420,7 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y -rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSection section@(SectionR op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr @@ -442,14 +443,14 @@ rnSection other = pprPanic "rnSection" (ppr other) ************************************************************************ -} -rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) +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 RdrName -> RnM (LHsCmdTop Name, FreeVars) +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where rnCmdTop' (HsCmdTop cmd _ _ _) @@ -463,10 +464,10 @@ rnCmdTop = wrapLocFstM rnCmdTop' (cmd_names `zip` cmd_names'), fvCmd `plusFV` cmd_fvs) } -rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd -rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) rnCmd (HsCmdArrApp arrow arg _ ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) @@ -541,10 +542,10 @@ type CmdNeeds = FreeVars -- Only inhabitants are -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) -methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds methodNamesLCmd = methodNamesCmd . unLoc -methodNamesCmd :: HsCmd Name -> CmdNeeds +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs @@ -572,7 +573,7 @@ methodNamesCmd (HsCmdCase _ matches) -- The type checker will complain later --------------------------------------------------- -methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where @@ -580,23 +581,23 @@ methodNamesMatch (MG { mg_alts = L _ ms }) ------------------------------------------------- -- gaw 2004 -methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds +methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars +methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars +methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc -methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd @@ -617,7 +618,7 @@ methodNamesStmt ApplicativeStmt{} = emptyFVs ************************************************************************ -} -rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) rnArithSeq (From expr) = do { (expr', fvExpr) <- rnLExpr expr ; return (From expr', fvExpr) } @@ -669,34 +670,34 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism. -} -- | Rename some Stmts -rnStmts :: Outputable (body RdrName) +rnStmts :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing - :: Outputable (body RdrName) + :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> (HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars)) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) -- ^ postprocess the statements - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], 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 @@ -707,8 +708,8 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts = do { -- rearrange the statements using ApplicativeStmt if @@ -724,17 +725,17 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts :: HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) -rnStmtsWithFreeVars :: Outputable (body RdrName) +rnStmtsWithFreeVars :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo. @@ -792,15 +793,15 @@ exhaustive list). How we deal with pattern match failure is context-dependent. At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body RdrName) +rnStmt :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of the statement - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -- ^ The statement -> ([Name] -> RnM (thing, FreeVars)) -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars @@ -938,18 +939,18 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" rnParallelStmts :: forall thing. HsStmtContext Name - -> SyntaxExpr Name - -> [ParStmtBlock RdrName RdrName] + -> SyntaxExpr GhcRn + -> [ParStmtBlock GhcPs GhcPs] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) -- Note [Renaming parallel Stmts] rnParallelStmts ctxt return_op segs thing_inside = do { orig_lcl_env <- getLocalRdrEnv ; rn_segs orig_lcl_env [] segs } where rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock RdrName RdrName] - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> [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 @@ -971,7 +972,7 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (head vs))) -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars) +lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntaxName, but respects contexts lookupStmtName ctxt n | rebindableContext ctxt @@ -979,7 +980,7 @@ lookupStmtName ctxt n | otherwise = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name | rebindableContext ctxt = do { rebindable_on <- xoptM LangExt.RebindableSyntax @@ -1047,13 +1048,13 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body RdrName) => - (Located (body RdrName) - -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] +rnRecStmtsAndThen :: Outputable (body GhcPs) => + (Located (body GhcPs) + -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt Name (Located (body Name)))] + -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen rnBody s cont @@ -1077,7 +1078,7 @@ rnRecStmtsAndThen rnBody s cont ; return (res, fvs) }} -- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> @@ -1089,11 +1090,11 @@ collectRecStmtsFixities l = -- left-hand sides rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt RdrName body + -> LStmt GhcPs body -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) = return [(L loc (BodyStmt body a b c), emptyFVs)] @@ -1135,8 +1136,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> [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) @@ -1149,11 +1150,11 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: (Outputable (body RdrName)) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmt :: (Outputable (body GhcPs)) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars) - -> RnM [Segment (LStmt Name (Located (body Name)))] + -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt @@ -1209,20 +1210,20 @@ rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _) rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body RdrName) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmts :: Outputable (body GhcPs) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] - -> RnM [Segment (LStmt Name (Located (body 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 Name body - -> [Segment (LStmt Name body)] -> FreeVars - -> ([LStmt Name body], FreeVars) + -> Stmt GhcRn body + -> [Segment (LStmt GhcRn body)] -> FreeVars + -> ([LStmt GhcRn body], FreeVars) segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later | null segs @@ -1324,8 +1325,9 @@ glom it together with the first two groups -} glomSegments :: HsStmtContext Name - -> [Segment (LStmt Name body)] - -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts + -> [Segment (LStmt GhcRn body)] + -> [Segment [LStmt GhcRn body]] + -- Each segment has a non-empty list of Stmts -- See Note [Glomming segments] glomSegments _ [] = [] @@ -1354,10 +1356,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) ---------------------------------------------------- -segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name body], FreeVars) +segsToStmts :: Stmt GhcRn body + -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt GhcRn body]] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn body], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1499,8 +1503,8 @@ data MonadNames = MonadNames { return_name, pure_name :: Name } -- Note [ApplicativeDo]. rearrangeForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) @@ -1532,12 +1536,12 @@ flattenStmtTree t = go t [] go (StmtTreeBind l r) as = go l (go r as) go (StmtTreeApplicative ts) as = foldr go as ts -type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars) +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) type Cost = Int -- | Turn a sequence of statements into an ExprStmtTree using a -- heuristic algorithm. /O(n^2)/ -mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeHeuristic [one] = StmtTreeOne one mkStmtTreeHeuristic stmts = case segments stmts of @@ -1551,7 +1555,7 @@ mkStmtTreeHeuristic stmts = -- | Turn a sequence of statements into an ExprStmtTree optimally, -- using dynamic programming. /O(n^3)/ -mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts = ASSERT(not (null stmts)) -- the empty case is handled by the caller; -- we don't support empty StmtTrees. @@ -1618,9 +1622,9 @@ stmtTreeToStmts :: MonadNames -> HsStmtContext Name -> ExprStmtTree - -> [ExprLStmt Name] -- ^ the "tail" + -> [ExprLStmt GhcRn] -- ^ the "tail" -> FreeVars -- ^ free variables of the tail - -> RnM ( [ExprLStmt Name] -- ( output statements, + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, , FreeVars ) -- , things we needed -- If we have a single bind, and we can do it without a join, transform @@ -1679,8 +1683,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do -- | Divide a sequence of statements into segments, where no segment -- depends on any variables defined by a statement in another segment. segments - :: [(ExprLStmt Name, FreeVars)] - -> [[(ExprLStmt Name, FreeVars)]] + :: [(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) @@ -1702,7 +1706,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) -- the sequence from the back to the front, and keeping track of -- the set of free variables of the current segment. Whenever -- this set of free variables is empty, we have a complete segment. - walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]] + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] walk [] = [] walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest where (seg,rest) = chunter fvs' stmts @@ -1732,9 +1736,9 @@ isLetStmt _ = False -- heuristic is to peel off the first group of independent statements -- and put the bind after those. splitSegment - :: [(ExprLStmt Name, FreeVars)] - -> ( [(ExprLStmt Name, FreeVars)] - , [(ExprLStmt Name, FreeVars)] ) + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) splitSegment [one,two] = ([one],[two]) -- there is no choice when there are only two statements; this just saves -- some work in a common case. @@ -1749,10 +1753,10 @@ splitSegment stmts _other -> (stmts,[]) slurpIndependentStmts - :: [(LStmt Name (Located (body Name)), FreeVars)] - -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts - , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts - , [(LStmt Name (Located (body Name)), FreeVars)] ) + :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt @@ -1789,10 +1793,10 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt :: HsStmtContext Name - -> [ApplicativeArg Name Name] -- ^ The args + -> [ApplicativeArg GhcRn GhcRn] -- ^ The args -> Bool -- ^ True <=> need a join - -> [ExprLStmt Name] -- ^ The body statements - -> RnM ([ExprLStmt Name], FreeVars) + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName ; (ap_op, fvs2) <- lookupStmtName ctxt apAName @@ -1812,8 +1816,8 @@ mkApplicativeStmt ctxt args need_join body_stmts -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary. needJoin :: MonadNames - -> [ExprLStmt Name] - -> (Bool, [ExprLStmt Name]) + -> [ExprLStmt GhcRn] + -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg needJoin monad_names [L loc (LastStmt e _ t)] | Just arg <- isReturnApp monad_names e = @@ -1823,8 +1827,8 @@ needJoin _monad_names stmts = (True, stmts) -- | @Just e@, if the expression is @return e@ or @return $ e@, -- otherwise @Nothing@ isReturnApp :: MonadNames - -> LHsExpr Name - -> Maybe (LHsExpr Name) + -> 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 @@ -1864,9 +1868,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or ' emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) - -> RnM (LStmt RdrName (Located (body RdrName))) +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 @@ -1896,7 +1900,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -1923,7 +1927,7 @@ emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Validity + -> Stmt GhcPs (Located (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1941,7 +1945,7 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity +okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -1998,7 +2002,7 @@ okPArrStmt dflags _ stmt ApplicativeStmt {} -> emptyInvalid --------- -checkTupleSection :: [LHsTupArg RdrName] -> RnM () +checkTupleSection :: [LHsTupArg GhcPs] -> RnM () checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } @@ -2006,12 +2010,12 @@ checkTupleSection args msg = text "Illegal tuple section: use TupleSections" --------- -sectionErr :: HsExpr RdrName -> SDoc +sectionErr :: HsExpr GhcPs -> SDoc sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars) +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) |