X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=a496c66daa3f24f2e4a4094c720a5c98273b82dd;hp=716a85a3b3ad4ad094c8ecc0b11d58211e9b99bb;hb=67cb409159fa9136dff942b8baaec25909416022;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 716a85a..a496c66 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -10,6 +10,13 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module RnExpr ( rnLExpr, rnExpr, rnStmts ) where @@ -17,33 +24,31 @@ module RnExpr ( #include "HsVersions.h" import RnSource ( rnSrcDecls, rnSplice, checkTH ) -import RnBinds ( rnLocalBindsAndThen, rnValBinds, - rnMatchGroup, trimWith ) +import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, + rnMatchGroup, makeMiniFixityEnv) import HsSyn -import RnHsSyn import TcRnMonad import RnEnv -import OccName ( plusOccEnv ) +import HscTypes ( availNames ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) -import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, - dupFieldErr, checkTupSize ) +import RnTypes ( rnHsTypeFVs, + mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) +import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, + localRecNameMaker, rnLit, + rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize) +import RdrName ( mkRdrUnqual ) import DynFlags ( DynFlag(..) ) import BasicTypes ( FixityDirection(..) ) +import SrcLoc ( SrcSpan ) import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - negateName, thenMName, bindMName, failMName ) -#if defined(GHCI) && defined(BREAKPOINT) -import PrelNames ( breakpointJumpName, undefined_RDR, breakpointIdKey ) -import UniqFM ( eltsUFM ) -import DynFlags ( GhcMode(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine ) -import Name ( isTyVarName ) -#endif -import Name ( Name, nameOccName, nameIsLocalOrFrom ) + negateName, thenMName, bindMName, failMName, groupWithName ) + +import Name ( Name, nameOccName, nameModule, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) -import LoadIface ( loadHomeInterface ) +import UniqFM +import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) +import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import List ( nub ) @@ -51,7 +56,7 @@ import Util ( isSingleton ) import ListSetOps ( removeDups ) import Maybes ( expectJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import FastString import List ( unzip4 ) @@ -95,35 +100,30 @@ rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) rnExpr (HsVar v) = do name <- lookupOccRn v - localRdrEnv <- getLocalRdrEnv - lclEnv <- getLclEnv ignore_asserts <- doptM Opt_IgnoreAsserts - ignore_breakpoints <- doptM Opt_IgnoreBreakpoints - let conds = [ (name `hasKey` assertIdKey - && not ignore_asserts, - do (e, fvs) <- mkAssertErrorExpr - return (e, fvs `addOneFV` name)) -#if defined(GHCI) && defined(BREAKPOINT) - , (name `hasKey` breakpointIdKey - && not ignore_breakpoints, - do ghcMode <- getGhcMode - case ghcMode of - Interactive - -> do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` name) - _ -> return (HsVar name, unitFV name) - ) -#endif - ] - case lookup True conds of - Just action -> action - Nothing -> return (HsVar name, unitFV name) + finish_var ignore_asserts name + where + finish_var ignore_asserts name + | ignore_asserts || not (name `hasKey` assertIdKey) + = return (HsVar name, unitFV name) + | otherwise + = do { (e, fvs) <- mkAssertErrorExpr + ; return (e, fvs `addOneFV` name) } rnExpr (HsIPVar v) = newIPNameRn v `thenM` \ name -> returnM (HsIPVar name, emptyFVs) +rnExpr (HsLit lit@(HsString s)) + = do { + opt_OverloadedStrings <- doptM Opt_OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit (mkHsIsString s placeHolderType)) + else -- Same as below + rnLit lit `thenM_` + returnM (HsLit lit, emptyFVs) + } + rnExpr (HsLit lit) = rnLit lit `thenM_` returnM (HsLit lit, emptyFVs) @@ -194,6 +194,9 @@ rnExpr (HsCoreAnn ann expr) rnExpr (HsSCC lbl expr) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) +rnExpr (HsTickPragma info expr) + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> @@ -216,36 +219,34 @@ rnExpr e@(HsDo do_or_lc stmts body _) rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> - returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) + returnM (ExplicitList placeHolderType exps', fvs) rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> returnM (ExplicitPArr placeHolderType exps', fvs) rnExpr e@(ExplicitTuple exps boxity) - = checkTupSize tup_size `thenM_` + = checkTupSize (length exps) `thenM_` rnExprs exps `thenM` \ (exps', fvs) -> - returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) - where - tup_size = length exps - tycon_name = tupleTyCon_name boxity tup_size + returnM (ExplicitTuple exps' boxity, fvs) rnExpr (RecordCon con_id _ rbinds) - = lookupLocatedOccRn con_id `thenM` \ conname -> - rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordCon conname noPostTcExpr rbinds', - fvRbinds `addOneFV` unLoc conname) + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } -rnExpr (RecordUpd expr rbinds _ _) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType, - fvExpr `plusFV` fvRbinds) +rnExpr (RecordUpd expr rbinds _ _ _) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds + ; return (RecordUpd expr' rbinds' [] [] [], + fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> - returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + = do { (pty', fvTy) <- rnHsTypeFVs doc pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } where doc = text "In an expression type signature" @@ -289,7 +290,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e \begin{code} rnExpr (HsProc pat body) = newArrowScope $ - rnPatsAndThen ProcExpr [pat] $ \ [pat'] -> + rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] -> rnCmdTop body `thenM` \ (body',fvBody) -> returnM (HsProc pat' body', fvBody) @@ -324,7 +325,7 @@ rnExpr (HsArrForm op fixity cmds) returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- DictApp, DictLam, TyApp, TyLam + -- HsWrap \end{code} @@ -453,7 +454,7 @@ methodNamesCmd other = emptyFVs -- The type checker will complain later --------------------------------------------------- -methodNamesMatch (MatchGroup ms ty) +methodNamesMatch (MatchGroup ms _) = plusFVs (map do_one ms) where do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss @@ -477,7 +478,9 @@ methodNamesStmt (RecStmt stmts _ _ _ _) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt b) = emptyFVs methodNamesStmt (ParStmt ss) = emptyFVs - -- ParStmt can't occur in commands, but it's not convenient to error +methodNamesStmt (TransformStmt _ _ _) = emptyFVs +methodNamesStmt (GroupStmt _ _) = emptyFVs + -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@ -511,29 +514,6 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} - -%************************************************************************ -%* * -\subsubsection{@Rbinds@s and @Rpats@s: in record expressions} -%* * -%************************************************************************ - -\begin{code} -rnRbinds str rbinds - = mappM_ field_dup_err dup_fields `thenM_` - mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> - returnM (rbinds', fvRbind) - where - (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ] - - field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups - - rn_rbind (field, expr) - = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> - rnLExpr expr `thenM` \ (expr', fvExpr) -> - returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname) -\end{code} - %************************************************************************ %* * Template Haskell brackets @@ -544,7 +524,7 @@ rnRbinds str rbinds rnBracket (VarBr n) = do { name <- lookupOccRn n ; this_mod <- getModule ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { loadHomeInterface msg name -- home interface is loaded, and this is the + do { loadInterfaceForName msg name -- home interface is loaded, and this is the ; return () } -- only way that is going to happen ; returnM (VarBr name, unitFV name) } where @@ -552,44 +532,41 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } -rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p - ; return (PatBr p', fvs) } + +rnBracket (PatBr p) = do { addErr (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")); + failM } + rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t ; return (TypBr t', fvs) } where doc = ptext SLIT("In a Template-Haskell quoted type") rnBracket (DecBr group) - = do { gbl_env <- getGblEnv - - ; let gbl_env1 = gbl_env { tcg_mod = thFAKE } - -- Note the thFAKE. The top-level names from the bracketed - -- declarations will go into the name cache, and we don't want them to - -- confuse the Names for the current module. - -- By using a pretend module, thFAKE, we keep them safely out of the way. - - ; names <- getLocalDeclBinders gbl_env1 group - ; rdr_env' <- extendRdrEnvRn emptyGlobalRdrEnv names - -- Furthermore, the names in the bracket shouldn't conflict with - -- existing top-level names E.g. + = do { gbl_env <- getGblEnv + + ; let new_gbl_env = gbl_env { -- Set the module to thFAKE. The top-level names from the bracketed + -- declarations will go into the name cache, and we don't want them to + -- confuse the Names for the current module. + -- By using a pretend module, thFAKE, we keep them safely out of the way. + tcg_mod = thFAKE, + + -- The emptyDUs is so that we just collect uses for this group alone + -- in the call to rnSrcDecls below + tcg_dus = emptyDUs } + ; setGblEnv new_gbl_env $ do { + + -- In this situation we want to *shadow* top-level bindings. -- foo = 1 - -- bar = [d| foo = 1|] - -- But both 'foo's get a LocalDef provenance, so we'd get a complaint unless - -- we start with an emptyGlobalRdrEnv - - ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env1 `plusOccEnv` rdr_env', - tcg_dus = emptyDUs }) $ do - -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want - -- to *shadow* top-level bindings. (See the 'foo' example above.) - -- If we don't shadow, we'll get an ambiguity complaint when we do - -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' - -- - -- Furthermore, arguably if the splice does define foo, that should hide - -- any foo's further out - -- - -- The emptyDUs is so that we just collect uses for this group alone - - { (tcg_env, group') <- rnSrcDecls group - -- Discard the tcg_env; it contains only extra info about fixity + -- bar = [d| foo = 1 |] + -- If we don't shadow, we'll get an ambiguity complaint when we do + -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' + -- + -- Furthermore, arguably if the splice does define foo, that should hide + -- any foo's further out + -- + -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag + ; (tcg_env, group') <- rnSrcDecls True group + + -- Discard the tcg_env; it contains only extra info about fixity ; return (DecBr group', allUses (tcg_dus tcg_env)) } } \end{code} @@ -614,15 +591,15 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -- Implements nested scopes rnNormalStmts ctxt [] thing_inside - = do { (thing, fvs) <- thing_inside + = do { (thing, fvs) <- thing_inside ; return (([],thing), fvs) } rnNormalStmts ctxt (L loc stmt : stmts) thing_inside - = do { ((stmt', (stmts', thing)), fvs) - <- rnStmt ctxt stmt $ - rnNormalStmts ctxt stmts thing_inside + = do { ((stmt', (stmts', thing)), fvs) <- rnStmt ctxt stmt $ + rnNormalStmts ctxt stmts thing_inside ; return (((L loc stmt' : stmts'), thing), fvs) } - + + rnStmt :: HsStmtContext Name -> Stmt RdrName -> RnM (thing, FreeVars) -> RnM ((Stmt Name, thing), FreeVars) @@ -639,19 +616,18 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupSyntaxName bindMName ; (fail_op, fvs2) <- lookupSyntaxName failMName - ; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do + ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do { (thing, fvs3) <- thing_inside ; return ((BindStmt pat' expr' bind_op fail_op, thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} - -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (LetStmt binds) thing_inside - = do { checkErr (ok ctxt binds) - (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) - ; rnLocalBindsAndThen binds $ \ binds' -> do - { (thing, fvs) <- thing_inside - ; return ((LetStmt binds', thing), fvs) }} +rnStmt ctxt (LetStmt binds) thing_inside = do + checkErr (ok ctxt binds) (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) + rnLocalBindsAndThen binds $ \binds' -> do + (thing, fvs) <- thing_inside + return ((LetStmt binds', thing), fvs) where -- We do not allow implicit-parameter bindings in a parallel -- list comprehension. I'm not sure what it might mean. @@ -659,8 +635,8 @@ rnStmt ctxt (LetStmt binds) thing_inside ok _ _ = True rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside - = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs -> - rn_rec_stmts bndrs rec_stmts `thenM` \ segs -> + = + rn_rec_stmts_and_then rec_stmts $ \ segs -> thing_inside `thenM` \ (thing, fvs) -> let segs_w_fwd_refs = addFwdRefs segs @@ -674,58 +650,163 @@ rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside where doc = text "In a recursive do statement" +rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do + checkIsTransformableListComp ctxt + + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + ((stmts', binders, (maybeByExpr', thing)), fvs) <- + rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do + (maybeByExpr', fv_maybeByExpr) <- rnMaybeLExpr maybeByExpr + (thing, fv_thing) <- thing_inside + + return ((maybeByExpr', thing), fv_maybeByExpr `plusFV` fv_thing) + + return ((TransformStmt (stmts', binders) usingExpr' maybeByExpr', thing), fv_usingExpr `plusFV` fvs) + where + rnMaybeLExpr Nothing = return (Nothing, emptyFVs) + rnMaybeLExpr (Just expr) = do + (expr', fv_expr) <- rnLExpr expr + return (Just expr', fv_expr) + +rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do + checkIsTransformableListComp ctxt + + -- We must rename the using expression in the context before the transform is begun + groupByClauseAction <- + case groupByClause of + GroupByNothing usingExpr -> do + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + (return . return) (GroupByNothing usingExpr', fv_usingExpr) + GroupBySomething eitherUsingExpr byExpr -> do + (eitherUsingExpr', fv_eitherUsingExpr) <- + case eitherUsingExpr of + Right _ -> return (Right $ HsVar groupWithName, unitNameSet groupWithName) + Left usingExpr -> do + (usingExpr', fv_usingExpr) <- rnLExpr usingExpr + return (Left usingExpr', fv_usingExpr) + + return $ do + (byExpr', fv_byExpr) <- rnLExpr byExpr + return (GroupBySomething eitherUsingExpr' byExpr', fv_eitherUsingExpr `plusFV` fv_byExpr) + + -- We only use rnNormalStmtsAndFindUsedBinders to get unshadowed_bndrs, so + -- perhaps we could refactor this to use rnNormalStmts directly? + ((stmts', _, (groupByClause', usedBinderMap, thing)), fvs) <- + rnNormalStmtsAndFindUsedBinders (TransformStmtCtxt ctxt) stmts $ \unshadowed_bndrs -> do + (groupByClause', fv_groupByClause) <- groupByClauseAction + + unshadowed_bndrs' <- mapM newLocalName unshadowed_bndrs + let binderMap = zip unshadowed_bndrs unshadowed_bndrs' + + -- Bind the "thing" inside a context where we have REBOUND everything + -- bound by the statements before the group. This is necessary since after + -- the grouping the same identifiers actually have different meanings + -- i.e. they refer to lists not singletons! + (thing, fv_thing) <- bindLocalNames unshadowed_bndrs' thing_inside + + -- We remove entries from the binder map that are not used in the thing_inside. + -- We can then use that usage information to ensure that the free variables do + -- not contain the things we just bound, but do contain the things we need to + -- make those bindings (i.e. the corresponding non-listy variables) + + -- Note that we also retain those entries which have an old binder in our + -- own free variables (the using or by expression). This is because this map + -- is reused in the desugarer to create the type to bind from the statements + -- that occur before this one. If the binders we need are not in the map, they + -- will never get bound into our desugared expression and hence the simplifier + -- crashes as we refer to variables that don't exist! + let usedBinderMap = filter + (\(old_binder, new_binder) -> + (new_binder `elemNameSet` fv_thing) || + (old_binder `elemNameSet` fv_groupByClause)) binderMap + (usedOldBinders, usedNewBinders) = unzip usedBinderMap + real_fv_thing = (delListFromNameSet fv_thing usedNewBinders) `plusFV` (mkNameSet usedOldBinders) + + return ((groupByClause', usedBinderMap, thing), fv_groupByClause `plusFV` real_fv_thing) + + traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap) + return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs) + rnStmt ctxt (ParStmt segs) thing_inside - = do { opt_GlasgowExts <- doptM Opt_GlasgowExts - ; checkM opt_GlasgowExts parStmtErr - ; orig_lcl_env <- getLocalRdrEnv - ; ((segs',thing), fvs) <- go orig_lcl_env [] segs + = do { parallel_list_comp <- doptM Opt_ParallelListComp + ; checkM parallel_list_comp parStmtErr + ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside ; return ((ParStmt segs', thing), fvs) } + + +rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name + -> [LStmt RdrName] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], [Name], thing), FreeVars) +rnNormalStmtsAndFindUsedBinders ctxt stmts thing_inside = do + ((stmts', (used_bndrs, inner_thing)), fvs) <- rnNormalStmts ctxt stmts $ do + -- Find the Names that are bound by stmts that + -- by assumption we have just renamed + local_env <- getLocalRdrEnv + let + stmts_binders = collectLStmtsBinders stmts + bndrs = map (expectJust "rnStmt" + . lookupLocalRdrEnv local_env + . unLoc) stmts_binders + + -- If shadow, we'll look up (Unqual x) twice, getting + -- the second binding both times, which is the + -- one we want + unshadowed_bndrs = nub bndrs + + -- Typecheck the thing inside, passing on all + -- the Names bound before it for its information + (thing, fvs) <- thing_inside unshadowed_bndrs + + -- Figure out which of the bound names are used + -- after the statements we renamed + let used_bndrs = filter (`elemNameSet` fvs) bndrs + return ((used_bndrs, thing), fvs) + + -- Flatten the tuple returned by the above call a bit! + return ((stmts', used_bndrs, inner_thing), fvs) + + +rnParallelStmts ctxt segs thing_inside = do + orig_lcl_env <- getLocalRdrEnv + go orig_lcl_env [] segs + where + go orig_lcl_env bndrs [] = do + let (bndrs', dups) = removeDups cmpByOcc bndrs + inner_env = extendLocalRdrEnv orig_lcl_env bndrs' + + mappM dupErr dups + (thing, fvs) <- setLocalRdrEnv inner_env thing_inside + return (([], thing), fvs) + + go orig_lcl_env bndrs_so_far ((stmts, _) : segs) = do + ((stmts', bndrs, (segs', thing)), fvs) <- rnNormalStmtsAndFindUsedBinders ctxt stmts $ \new_bndrs -> do + -- Typecheck the thing inside, passing on all + -- the Names bound, but separately; revert the envt + setLocalRdrEnv orig_lcl_env $ do + go orig_lcl_env (new_bndrs ++ bndrs_so_far) segs + + let seg' = (stmts', bndrs) + return (((seg':segs'), thing), delListFromNameSet fvs bndrs) + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr (head vs))) + + +checkIsTransformableListComp :: HsStmtContext Name -> RnM () +checkIsTransformableListComp ctxt = do + -- Ensure we are really within a list comprehension because otherwise the + -- desugarer will break when we come to operate on a parallel array + checkM (notParallelArray ctxt) transformStmtOutsideListCompErr + + -- Ensure the user has turned the correct flag on + transform_list_comp <- doptM Opt_TransformListComp + checkM transform_list_comp transformStmtErr where --- type ParSeg id = [([LStmt id], [id])] --- go :: NameSet -> [ParSeg RdrName] --- -> RnM (([ParSeg Name], thing), FreeVars) - - go orig_lcl_env bndrs [] - = do { let { (bndrs', dups) = removeDups cmpByOcc bndrs - ; inner_env = extendLocalRdrEnv orig_lcl_env bndrs' } - ; mappM dupErr dups - ; (thing, fvs) <- setLocalRdrEnv inner_env thing_inside - ; return (([], thing), fvs) } - - go orig_lcl_env bndrs_so_far ((stmts, _) : segs) - = do { ((stmts', (bndrs, segs', thing)), fvs) - <- rnNormalStmts par_ctxt stmts $ do - { -- Find the Names that are bound by stmts - lcl_env <- getLocalRdrEnv - ; let { rdr_bndrs = collectLStmtsBinders stmts - ; bndrs = map ( expectJust "rnStmt" - . lookupLocalRdrEnv lcl_env - . unLoc) rdr_bndrs - ; new_bndrs = nub bndrs ++ bndrs_so_far - -- The nub is because there might be shadowing - -- x <- e1; x <- e2 - -- So we'll look up (Unqual x) twice, getting - -- the second binding both times, which is the - } -- one we want - - -- Typecheck the thing inside, passing on all - -- the Names bound, but separately; revert the envt - ; ((segs', thing), fvs) <- setLocalRdrEnv orig_lcl_env $ - go orig_lcl_env new_bndrs segs - - -- Figure out which of the bound names are used - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs - ; return ((used_bndrs, segs', thing), fvs) } - - ; let seg' = (stmts', bndrs) - ; return (((seg':segs'), thing), - delListFromNameSet fvs bndrs) } - - par_ctxt = ParStmtCtxt ctxt - - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") - <+> quotes (ppr (head vs))) + notParallelArray PArrComp = False + notParallelArray _ = True + \end{code} @@ -746,38 +827,37 @@ type Segment stmts = (Defs, ---------------------------------------------------- + rnMDoStmts :: [LStmt RdrName] -> RnM (thing, FreeVars) -> RnM (([LStmt Name], thing), FreeVars) rnMDoStmts stmts thing_inside - = -- Step1: bring all the binders of the mdo into scope - -- Remember that this also removes the binders from the - -- finally-returned free-vars - bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ bndrs -> - do { - -- Step 2: Rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) - segs <- rn_rec_stmts bndrs stmts + = -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + rn_rec_stmts_and_then stmts $ \ segs -> do { ; (thing, fvs_later) <- thing_inside ; let - -- Step 3: Fill in the fwd refs. + -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref -- field mentions all the things used by the segment -- that are bound after their use segs_w_fwd_refs = addFwdRefs segs - -- Step 4: Group together the segments to make bigger segments + -- Step 3: Group together the segments to make bigger segments -- Invariant: in the result, no segment uses a variable -- bound in a later segment grouped_segs = glomSegments segs_w_fwd_refs - -- Step 5: Turn the segments into Stmts + -- Step 4: Turn the segments into Stmts -- Use RecStmt when and only when there are fwd refs -- Also gather up the uses from the end towards the -- start, so we can tell the RecStmt which things are @@ -789,25 +869,112 @@ rnMDoStmts stmts thing_inside doc = text "In a recursive mdo-expression" --------------------------------------------- -rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)] -rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts `thenM` \ segs_s -> - returnM (concat segs_s) ----------------------------------------------------- -rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)] +-- wrapper that does both the left- and right-hand sides +rn_rec_stmts_and_then :: [LStmt RdrName] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rn_rec_stmts_and_then s cont = do + -- (A) make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) do the LHSes + new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- bring them and their fixities into scope + let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv) + bindLocalNamesFV_WithFixities bound_names fix_env $ + warnUnusedLocalBinds bound_names $ do + + -- (C) do the right-hand-sides and thing-inside + segs <- rn_rec_stmts bound_names new_lhs_and_fv + cont segs + + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L loc (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> LStmt RdrName + -- 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, FreeVars)] + +rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), + -- this is actually correct + emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + return [(L loc (BindStmt pat' expr a b), + fv_pat)] + +rn_rec_stmt_lhs fix_env (L loc (LetStmt binds@(HsIPBinds _))) + = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) + ; failM } + +rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) + = do binds' <- rnValBindsLHS fix_env binds + return [(L loc (LetStmt (HsValBinds binds')), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +rn_rec_stmt_lhs fix_env (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmts_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind + -- these fixities need to be brought into scope with the names + -> [LStmt RdrName] + -> RnM [(LStmtLR Name RdrName, FreeVars)] +rn_rec_stmts_lhs fix_env stmts = + let boundNames = collectLStmtsBinders stmts + doc = text "In a recursive mdo-expression" + in do + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + checkDupNames doc boundNames + mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls) + + +-- right-hand-sides + +rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt - -rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) - = rnLExpr expr `thenM` \ (expr', fvs) -> +rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) _ + = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (ExprStmt expr' then_op placeHolderType))] -rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) +rn_rec_stmt all_bndrs (L loc (BindStmt pat' expr _ _)) fv_pat = rnLExpr expr `thenM` \ (expr', fv_expr) -> - rnLPat pat `thenM` \ (pat', fv_pat) -> lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let @@ -817,20 +984,33 @@ rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt pat' expr' bind_op fail_op))] -rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) +rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) _ = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) ; failM } -rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds))) - = rnValBinds (trimWith all_bndrs) binds `thenM` \ (binds', du_binds) -> - returnM [(duDefs du_binds, duUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] +rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do + (binds', du_binds) <- + -- fixities and unused are handled above in rn_rec_stmts_and_then + rnValBindsRHS all_bndrs binds' + returnM [(duDefs du_binds, duUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec - = rn_rec_stmts all_bndrs stmts +-- no RecStmt case becuase they get flattened above when doing the LHSes +rn_rec_stmt all_bndrs stmt@(L loc (RecStmt stmts _ _ _ _)) _ + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) -rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) +rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmt all_bndrs stmt@(L _ (TransformStmt _ _ _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) + +rn_rec_stmt all_bndrs stmt@(L _ (GroupStmt _ _)) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt) + +rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)] +rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s -> + returnM (concat segs_s) --------------------------------------------- addFwdRefs :: [Segment a] -> [Segment a] @@ -935,44 +1115,21 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ %* * -\subsubsection{breakpoint utils} -%* * -%************************************************************************ - -\begin{code} -#if defined(GHCI) && defined(BREAKPOINT) -mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakPointExpr scope - = do sloc <- getSrcSpanM - undef <- lookupOccRn undefined_RDR - let inLoc = L sloc - lHsApp x y = inLoc (HsApp x y) - mkExpr fnName args = mkExpr' fnName (reverse args) - mkExpr' fnName [] = inLoc (HsVar fnName) - mkExpr' fnName (arg:args) - = lHsApp (mkExpr' fnName args) (inLoc arg) - expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg] - mkScopeArg args - = unLoc $ mkExpr undef (map HsVar args) - msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc))) - return (expr, emptyFVs) -#endif -\end{code} - -%************************************************************************ -%* * \subsubsection{Assertion utils} %* * %************************************************************************ \begin{code} +srcSpanPrimLit :: SrcSpan -> HsExpr Name +srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span)))) + mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) -- Return an expression for (assertError "Foo.hs:27") mkAssertErrorExpr = getSrcSpanM `thenM` \ sloc -> let - expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg)) - msg = HsStringPrim (mkFastString (showSDoc (ppr sloc))) + expr = HsApp (L sloc (HsVar assertErrorName)) + (L sloc (srcSpanPrimLit sloc)) in returnM (expr, emptyFVs) \end{code} @@ -988,9 +1145,15 @@ patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context nest 4 (ppr e)]) ; return (EWildPat, emptyFVs) } -parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts")) + +parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp")) + +transformStmtErr = addErr (ptext SLIT("Illegal transform or grouping list comprehension: use -XTransformListComp")) +transformStmtOutsideListCompErr = addErr (ptext SLIT("Currently you may only use transform or grouping comprehensions within list comprehensions, not parallel array comprehensions")) badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} + +