X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=bccd2e22af3abbde579b66b018af73b4165ee7ca;hp=87af074190aece82bbfebec46177540450a0a0b6;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=0fa697bca153468bf073aad1fe02d5b4055059f2 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 87af074..bccd2e2 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_GHC -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/WorkingConventions#Warnings +-- for details + module RnExpr ( rnLExpr, rnExpr, rnStmts ) where @@ -20,31 +27,24 @@ import RnSource ( rnSrcDecls, rnSplice, checkTH ) import RnBinds ( rnLocalBindsAndThen, rnValBinds, rnMatchGroup, trimWith ) 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 ) + rnHsRecFields, checkTupSize ) 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, breakpointCondJumpName - , undefined_RDR, breakpointIdKey, breakpointCondIdKey ) -import UniqFM ( eltsUFM ) -import DynFlags ( GhcMode(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine ) -import Name ( isTyVarName ) -#endif + import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) -import LoadIface ( loadHomeInterface ) +import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) +import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import List ( nub ) @@ -52,7 +52,7 @@ import Util ( isSingleton ) import ListSetOps ( removeDups ) import Maybes ( expectJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated ) +import SrcLoc ( Located(..), unLoc, getLoc ) import FastString import List ( unzip4 ) @@ -96,40 +96,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 - ghcMode <- getGhcMode - 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 - && ghcMode == Interactive, - do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakpointExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` name) - ) - , (name `hasKey` breakpointCondIdKey - && not ignore_breakpoints - && ghcMode == Interactive, - do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakpointCondExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` 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)) + else -- Same as below + rnLit lit `thenM_` + returnM (HsLit lit, emptyFVs) + } + rnExpr (HsLit lit) = rnLit lit `thenM_` returnM (HsLit lit, emptyFVs) @@ -200,6 +190,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) -> @@ -222,36 +215,35 @@ 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) - -rnExpr (RecordUpd expr rbinds _ _) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType, - fvExpr `plusFV` fvRbinds) + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecFields "construction" (Just conname) + rnLExpr HsVar rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } + +rnExpr (RecordUpd expr rbinds _ _ _) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecFields "update" Nothing rnLExpr HsVar 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" @@ -330,7 +322,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} @@ -459,7 +451,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 @@ -517,29 +509,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 @@ -550,7 +519,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 @@ -573,25 +542,27 @@ rnBracket (DecBr group) -- 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. + ; avails <- getLocalDeclBinders gbl_env1 group + ; let names = concatMap availNames avails + + ; let new_occs = map nameOccName names + trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs + + ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails + -- 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', + -- 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 the call to hideSomeUnquals, which removes + -- the unqualified bindings of things defined by the bracket + + ; setGblEnv (gbl_env { tcg_rdr_env = 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 @@ -681,8 +652,8 @@ rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside doc = text "In a recursive do statement" rnStmt ctxt (ParStmt segs) thing_inside - = do { opt_GlasgowExts <- doptM Opt_GlasgowExts - ; checkM opt_GlasgowExts parStmtErr + = do { parallel_list_comp <- doptM Opt_ParallelListComp + ; checkM parallel_list_comp parStmtErr ; orig_lcl_env <- getLocalRdrEnv ; ((segs',thing), fvs) <- go orig_lcl_env [] segs ; return ((ParStmt segs', thing), fvs) } @@ -941,50 +912,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 = mkBreakpointExpr' breakpointJumpName - -mkBreakpointCondExpr :: [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakpointCondExpr = mkBreakpointExpr' breakpointCondJumpName - -mkBreakpointExpr' :: Name -> [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakpointExpr' breakpointFunc 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 breakpointFunc [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} @@ -1000,9 +942,11 @@ 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")) badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} + +