summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.lhs7
-rw-r--r--compiler/rename/RnEnv.lhs56
-rw-r--r--compiler/rename/RnExpr.lhs232
-rw-r--r--compiler/rename/RnNames.lhs32
-rw-r--r--compiler/rename/RnPat.lhs9
-rw-r--r--compiler/rename/RnSource.lhs73
-rw-r--r--compiler/rename/RnSplice.lhs2
-rw-r--r--compiler/rename/RnTypes.lhs15
8 files changed, 223 insertions, 203 deletions
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 7251492ccf..e65d3173d6 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -9,7 +9,7 @@ type-synonym declarations; those cannot be done at this stage because
they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
@@ -476,8 +476,9 @@ rnBind _ bind@(PatBind { pat_lhs = pat
bndrs = collectPatBinders pat
bind' = bind { pat_rhs = grhss', bind_fvs = fvs' }
is_wild_pat = case pat of
- L _ (WildPat {}) -> True
- _ -> False
+ L _ (WildPat {}) -> True
+ L _ (BangPat (L _ (WildPat {}))) -> True -- #9127
+ _ -> False
-- Warn if the pattern binds no variables, except for the
-- entirely-explicit idiom _ = rhs
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 178f722d99..f333a239a1 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -4,6 +4,8 @@
\section[RnEnv]{Environment manipulation for the renamer monad}
\begin{code}
+{-# LANGUAGE CPP #-}
+
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
@@ -38,10 +40,7 @@ module RnEnv (
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, kindSigErr, perhapsForallMsg,
- HsDocContext(..), docOfHsDocContext,
-
- -- FsEnv
- FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
+ HsDocContext(..), docOfHsDocContext
) where
#include "HsVersions.h"
@@ -59,7 +58,6 @@ import NameSet
import NameEnv
import Avail
import Module
-import UniqFM
import ConLike
import DataCon ( dataConFieldLabels, dataConTyCon )
import TyCon ( isTupleTyCon, tyConArity )
@@ -270,22 +268,29 @@ lookupExactOcc name
; return name
}
- (gre:_) -> return (gre_name gre) }
+ [gre] -> return (gre_name gre)
+ (gre:_) -> do {addErr dup_nm_err
+ ; return (gre_name gre)
+ }
-- We can get more than one GRE here, if there are multiple
- -- bindings for the same name; but there will already be a
- -- reported error for the duplicate. (If we add the error
- -- rather than stopping when we encounter it.)
- -- So all we need do here is not crash.
- -- Example is Trac #8932:
+ -- bindings for the same name. Sometimes they are caught later
+ -- by findLocalDupsRdrEnv, like in this example (Trac #8932):
-- $( [d| foo :: a->a; foo x = x |])
-- foo = True
- -- Here the 'foo' in the splice turns into an Exact Name
+ -- But when the names are totally identical, we panic (Trac #7241):
+ -- $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])
+ -- So, let's emit an error here, even if it will lead to duplication in some cases.
+ }
where
exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
, ptext (sLit "perhaps via newName, but did not bind it")
, ptext (sLit "If that's it, then -ddump-splices might be useful") ])
+ dup_nm_err = hang (ptext (sLit "Duplicate exact Name") <+> quotes (ppr $ nameOccName name))
+ 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
+ , ptext (sLit "perhaps via newName, but bound it multiple times")
+ , ptext (sLit "If that's it, then -ddump-splices might be useful") ])
-----------------------------------------------
lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
@@ -1080,20 +1085,6 @@ deprecation declarations, and lookup of names in GHCi.
\begin{code}
--------------------------------
-type FastStringEnv a = UniqFM a -- Keyed by FastString
-
-
-emptyFsEnv :: FastStringEnv a
-lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
-extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
-mkFsEnv :: [(FastString,a)] -> FastStringEnv a
-
-emptyFsEnv = emptyUFM
-lookupFsEnv = lookupUFM
-extendFsEnv = addToUFM
-mkFsEnv = listToUFM
-
---------------------------------
type MiniFixityEnv = FastStringEnv (Located Fixity)
-- Mini fixity env for the names we're about
-- to bind, in a single binding group
@@ -1461,7 +1452,7 @@ unknownNameSuggestErr where_look tried_rdr_name
all_possibilities
= [ (showPpr dflags r, (r, Left loc))
| (r,loc) <- local_possibilities local_env ]
- ++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ]
+ ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
perhaps = ptext (sLit "Perhaps you meant")
@@ -1473,19 +1464,24 @@ unknownNameSuggestErr where_look tried_rdr_name
; return extra_err }
where
pp_item :: (RdrName, HowInScope) -> SDoc
- pp_item (rdr, Left loc) = quotes (ppr rdr) <+> loc' -- Locally defined
+ pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined
where loc' = case loc of
UnhelpfulSpan l -> parens (ppr l)
RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l))
- pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
+ pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
+ pp_ns :: RdrName -> SDoc
+ pp_ns rdr | ns /= tried_ns = pprNameSpace ns
+ | otherwise = empty
+ where ns = rdrNameSpace rdr
+
tried_occ = rdrNameOcc tried_rdr_name
tried_is_sym = isSymOcc tried_occ
tried_ns = occNameSpace tried_occ
tried_is_qual = isQual tried_rdr_name
- correct_name_space occ = occNameSpace occ == tried_ns
+ correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns
&& isSymOcc occ == tried_is_sym
-- Treat operator and non-operators as non-matching
-- This heuristic avoids things like
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 01e8a4492d..d680292a25 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -10,6 +10,8 @@ general, all of these functions return a renamed thing, and a set of
free variables.
\begin{code}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+
module RnExpr (
rnLExpr, rnExpr, rnStmts
) where
@@ -45,16 +47,6 @@ import Control.Monad
import TysWiredIn ( nilDataConName )
\end{code}
-
-\begin{code}
--- XXX
-thenM :: Monad a => a b -> (b -> a c) -> a c
-thenM = (>>=)
-
-thenM_ :: Monad a => a b -> a c -> a c
-thenM_ = (>>)
-\end{code}
-
%************************************************************************
%* *
\subsubsection{Expressions}
@@ -66,16 +58,13 @@ rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
rnExprs ls = rnExprs' ls emptyUniqSet
where
rnExprs' [] acc = return ([], acc)
- rnExprs' (expr:exprs) acc
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
-
+ rnExprs' (expr:exprs) acc =
+ do { (expr', fvExpr) <- rnLExpr expr
-- Now we do a "seq" on the free vars because typically it's small
-- or empty, especially in very long lists of constants
- let
- acc' = acc `plusFV` fvExpr
- in
- acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
- return (expr':exprs', fvExprs)
+ ; let acc' = acc `plusFV` fvExpr
+ ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
+ ; return (expr':exprs', fvExprs) }
\end{code}
Variables. We look up the variable and return the resulting name.
@@ -120,27 +109,25 @@ rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
rnExpr (HsLit lit@(HsString s))
- = do {
- opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
+ = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit (mkHsIsString s placeHolderType))
- else -- Same as below
- rnLit lit `thenM_`
- return (HsLit lit, emptyFVs)
- }
+ else do {
+ ; rnLit lit
+ ; return (HsLit lit, emptyFVs) } }
rnExpr (HsLit lit)
- = rnLit lit `thenM_`
- return (HsLit lit, emptyFVs)
+ = do { rnLit lit
+ ; return (HsLit lit, emptyFVs) }
rnExpr (HsOverLit lit)
- = rnOverLit lit `thenM` \ (lit', fvs) ->
- return (HsOverLit lit', fvs)
+ = do { (lit', fvs) <- rnOverLit lit
+ ; return (HsOverLit lit', fvs) }
rnExpr (HsApp fun arg)
- = rnLExpr fun `thenM` \ (fun',fvFun) ->
- rnLExpr arg `thenM` \ (arg',fvArg) ->
- return (HsApp fun' arg', fvFun `plusFV` fvArg)
+ = do { (fun',fvFun) <- rnLExpr fun
+ ; (arg',fvArg) <- rnLExpr arg
+ ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
= do { (e1', fv_e1) <- rnLExpr e1
@@ -163,10 +150,10 @@ rnExpr (OpApp _ other_op _ _)
, ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
rnExpr (NegApp e _)
- = rnLExpr e `thenM` \ (e', fv_e) ->
- lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
- mkNegAppRn e' neg_name `thenM` \ final_e ->
- return (final_e, fv_e `plusFV` fv_neg)
+ = 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) }
------------------------------------------
-- Template Haskell extensions
@@ -178,10 +165,10 @@ rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
rnExpr (HsQuasiQuoteE qq)
- = runQuasiQuoteExpr qq `thenM` \ lexpr' ->
- -- Wrap the result of the quasi-quoter in parens so that we don't
- -- lose the outermost location set by runQuasiQuote (#7918)
- rnExpr (HsPar lexpr')
+ = do { lexpr' <- runQuasiQuoteExpr qq
+ -- Wrap the result of the quasi-quoter in parens so that we don't
+ -- lose the outermost location set by runQuasiQuote (#7918)
+ ; rnExpr (HsPar lexpr') }
---------------------------------------------
-- Sections
@@ -205,33 +192,33 @@ rnExpr expr@(SectionR {})
---------------------------------------------
rnExpr (HsCoreAnn ann expr)
- = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
- return (HsCoreAnn ann expr', fvs_expr)
+ = do { (expr', fvs_expr) <- rnLExpr expr
+ ; return (HsCoreAnn ann expr', fvs_expr) }
rnExpr (HsSCC lbl expr)
- = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
- return (HsSCC lbl expr', fvs_expr)
+ = do { (expr', fvs_expr) <- rnLExpr expr
+ ; return (HsSCC lbl expr', fvs_expr) }
rnExpr (HsTickPragma info expr)
- = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
- return (HsTickPragma info expr', fvs_expr)
+ = do { (expr', fvs_expr) <- rnLExpr expr
+ ; return (HsTickPragma info expr', fvs_expr) }
rnExpr (HsLam matches)
- = rnMatchGroup LambdaExpr rnLExpr matches `thenM` \ (matches', fvMatch) ->
- return (HsLam matches', fvMatch)
+ = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
+ ; return (HsLam matches', fvMatch) }
rnExpr (HsLamCase arg matches)
- = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) ->
- return (HsLamCase arg matches', fvs_ms)
+ = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
+ ; return (HsLamCase arg matches', fvs_ms) }
rnExpr (HsCase expr matches)
- = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
- rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (new_matches, ms_fvs) ->
- return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
+ = do { (new_expr, e_fvs) <- rnLExpr expr
+ ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
+ ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnExpr (HsLet binds expr)
- = rnLocalBindsAndThen binds $ \ binds' ->
- rnLExpr expr `thenM` \ (expr',fvExpr) ->
- return (HsLet binds' expr', fvExpr)
+ = rnLocalBindsAndThen binds $ \binds' -> do
+ { (expr',fvExpr) <- rnLExpr expr
+ ; return (HsLet binds' expr', fvExpr) }
rnExpr (HsDo do_or_lc stmts _)
= do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
@@ -248,8 +235,8 @@ rnExpr (ExplicitList _ _ exps)
return (ExplicitList placeHolderType Nothing exps', fvs) }
rnExpr (ExplicitPArr _ exps)
- = rnExprs exps `thenM` \ (exps', fvs) ->
- return (ExplicitPArr placeHolderType exps', fvs)
+ = do { (exps', fvs) <- rnExprs exps
+ ; return (ExplicitPArr placeHolderType exps', fvs) }
rnExpr (ExplicitTuple tup_args boxity)
= do { checkTupleSection tup_args
@@ -290,8 +277,8 @@ rnExpr (HsMultiIf ty alts)
; return (HsMultiIf ty alts', fvs) }
rnExpr (HsType a)
- = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) ->
- return (HsType t, fvT)
+ = do { (t, fvT) <- rnLHsType HsTypeCtx a
+ ; return (HsType t, fvT) }
rnExpr (ArithSeq _ _ seq)
= do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
@@ -304,8 +291,8 @@ rnExpr (ArithSeq _ _ seq)
return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
rnExpr (PArrSeq _ seq)
- = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- return (PArrSeq noPostTcExpr new_seq, fvs)
+ = do { (new_seq, fvs) <- rnArithSeq seq
+ ; return (PArrSeq noPostTcExpr new_seq, fvs) }
\end{code}
These three are pattern syntax appearing in expressions.
@@ -332,9 +319,9 @@ rnExpr e@(ELazyPat {}) = patSynErr e
\begin{code}
rnExpr (HsProc pat body)
= newArrowScope $
- rnPat ProcExpr pat $ \ pat' ->
- rnCmdTop body `thenM` \ (body',fvBody) ->
- return (HsProc pat' body', fvBody)
+ rnPat ProcExpr pat $ \ pat' -> do
+ { (body',fvBody) <- rnCmdTop body
+ ; return (HsProc pat' body', fvBody) }
-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
rnExpr e@(HsArrApp {}) = arrowFail e
@@ -402,9 +389,9 @@ rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
rnCmdArgs [] = return ([], emptyFVs)
rnCmdArgs (arg:args)
- = rnCmdTop arg `thenM` \ (arg',fvArg) ->
- rnCmdArgs args `thenM` \ (args',fvArgs) ->
- return (arg':args', fvArg `plusFV` fvArgs)
+ = do { (arg',fvArg) <- rnCmdTop arg
+ ; (args',fvArgs) <- rnCmdArgs args
+ ; return (arg':args', fvArg `plusFV` fvArgs) }
rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
rnCmdTop = wrapLocFstM rnCmdTop'
@@ -425,10 +412,10 @@ rnLCmd = wrapLocFstM rnCmd
rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
rnCmd (HsCmdArrApp arrow arg _ ho rtl)
- = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) ->
- rnLExpr arg `thenM` \ (arg',fvArg) ->
- return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
- fvArrow `plusFV` fvArg)
+ = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
+ ; (arg',fvArg) <- rnLExpr arg
+ ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
+ fvArrow `plusFV` fvArg) }
where
select_arrow_scope tc = case ho of
HsHigherOrderApp -> tc
@@ -441,42 +428,37 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
-- infix form
rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
- = escapeArrowScope (rnLExpr op)
- `thenM` \ (op',fv_op) ->
- let L _ (HsVar op_name) = op' in
- rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) ->
- rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) ->
-
+ = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
+ ; let L _ (HsVar op_name) = op'
+ ; (arg1',fv_arg1) <- rnCmdTop arg1
+ ; (arg2',fv_arg2) <- rnCmdTop arg2
-- Deal with fixity
-
- lookupFixityRn op_name `thenM` \ fixity ->
- mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e ->
-
- return (final_e,
- fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
+ ; fixity <- lookupFixityRn op_name
+ ; final_e <- mkOpFormRn arg1' op' fixity arg2'
+ ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
rnCmd (HsCmdArrForm op fixity cmds)
- = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) ->
- rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
- return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
+ = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
+ ; (cmds',fvCmds) <- rnCmdArgs cmds
+ ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
rnCmd (HsCmdApp fun arg)
- = rnLCmd fun `thenM` \ (fun',fvFun) ->
- rnLExpr arg `thenM` \ (arg',fvArg) ->
- return (HsCmdApp fun' arg', fvFun `plusFV` fvArg)
+ = do { (fun',fvFun) <- rnLCmd fun
+ ; (arg',fvArg) <- rnLExpr arg
+ ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
rnCmd (HsCmdLam matches)
- = rnMatchGroup LambdaExpr rnLCmd matches `thenM` \ (matches', fvMatch) ->
- return (HsCmdLam matches', fvMatch)
+ = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
+ ; return (HsCmdLam matches', fvMatch) }
rnCmd (HsCmdPar e)
= do { (e', fvs_e) <- rnLCmd e
; return (HsCmdPar e', fvs_e) }
rnCmd (HsCmdCase expr matches)
- = rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
- rnMatchGroup CaseAlt rnLCmd matches `thenM` \ (new_matches, ms_fvs) ->
- return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
+ = do { (new_expr, e_fvs) <- rnLExpr expr
+ ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
+ ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
rnCmd (HsCmdIf _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
@@ -486,9 +468,9 @@ rnCmd (HsCmdIf _ p b1 b2)
; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnCmd (HsCmdLet binds cmd)
- = rnLocalBindsAndThen binds $ \ binds' ->
- rnLCmd cmd `thenM` \ (cmd',fvExpr) ->
- return (HsCmdLet binds' cmd', fvExpr)
+ = rnLocalBindsAndThen binds $ \ binds' -> do
+ { (cmd',fvExpr) <- rnLCmd cmd
+ ; return (HsCmdLet binds' cmd', fvExpr) }
rnCmd (HsCmdDo stmts _)
= do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
@@ -578,25 +560,25 @@ methodNamesStmt (TransStmt {}) = emptyFVs
\begin{code}
rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
rnArithSeq (From expr)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
- return (From expr', fvExpr)
+ = do { (expr', fvExpr) <- rnLExpr expr
+ ; return (From expr', fvExpr) }
rnArithSeq (FromThen expr1 expr2)
- = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+ ; (expr2', fvExpr2) <- rnLExpr expr2
+ ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromTo expr1 expr2)
- = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+ ; (expr2', fvExpr2) <- rnLExpr expr2
+ ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
rnArithSeq (FromThenTo expr1 expr2 expr3)
- = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnLExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- rnLExpr expr3 `thenM` \ (expr3', fvExpr3) ->
- return (FromThenTo expr1' expr2' expr3',
- plusFVs [fvExpr1, fvExpr2, fvExpr3])
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+ ; (expr2', fvExpr2) <- rnLExpr expr2
+ ; (expr3', fvExpr3) <- rnLExpr expr3
+ ; return (FromThenTo expr1' expr2' expr3',
+ plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
\end{code}
%************************************************************************
@@ -959,21 +941,19 @@ rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _
L loc (LastStmt body' ret_op))] }
rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _
- = rnBody body `thenM` \ (body', fvs) ->
- lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
- return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))]
+ = do { (body', fvs) <- rnBody body
+ ; (then_op, fvs1) <- lookupSyntaxName thenMName
+ ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
+ L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat
- = rnBody body `thenM` \ (body', fv_expr) ->
- lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
- lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
- let
- bndrs = mkNameSet (collectPatBinders pat')
- fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
- in
- return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
- L loc (BindStmt pat' body' bind_op fail_op))]
+ = do { (body', fv_expr) <- rnBody body
+ ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+ ; (fail_op, fvs2) <- lookupSyntaxName failMName
+ ; let bndrs = mkNameSet (collectPatBinders pat')
+ fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
+ ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
+ L loc (BindStmt pat' body' bind_op fail_op))] }
rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _
= failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
@@ -1003,9 +983,9 @@ rn_rec_stmts :: Outputable (body RdrName) =>
-> [Name]
-> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
-> RnM [Segment (LStmt Name (Located (body Name)))]
-rn_rec_stmts rnBody bndrs stmts =
- mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s ->
- return (concat segs_s)
+rn_rec_stmts rnBody bndrs stmts
+ = do { segs_s <- mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts
+ ; return (concat segs_s) }
---------------------------------------------
segmentRecStmts :: HsStmtContext Name
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 7f6a840295..db4258607a 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -4,6 +4,8 @@
\section[RnNames]{Extracting imported and top-level names in scope}
\begin{code}
+{-# LANGUAGE CPP, NondecreasingIndentation #-}
+
module RnNames (
rnImports, getLocalNonValBinders,
rnExports, extendGlobalRdrEnvRn,
@@ -1301,11 +1303,14 @@ type ImportDeclUsage
warnUnusedImportDecls :: TcGblEnv -> RnM ()
warnUnusedImportDecls gbl_env
= do { uses <- readMutVar (tcg_used_rdrnames gbl_env)
- ; let imports = filter explicit_import (tcg_rn_imports gbl_env)
+ ; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env)
+ -- This whole function deals only with *user* imports
+ -- both for warning about unnecessary ones, and for
+ -- deciding the minimal ones
rdr_env = tcg_rdr_env gbl_env
; let usage :: [ImportDeclUsage]
- usage = findImportUsage imports rdr_env (Set.elems uses)
+ usage = findImportUsage user_imports rdr_env (Set.elems uses)
; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
, ptext (sLit "Import usage") <+> ppr usage])
@@ -1314,10 +1319,6 @@ warnUnusedImportDecls gbl_env
; whenGOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
- where
- explicit_import (L _ decl) = not (ideclImplicit decl)
- -- Filter out the implicit Prelude import
- -- which we do not want to bleat about
\end{code}
@@ -1433,6 +1434,11 @@ warnUnusedImport :: ImportDeclUsage -> RnM ()
warnUnusedImport (L loc decl, used, unused)
| Just (False,[]) <- ideclHiding decl
= return () -- Do not warn for 'import M()'
+
+ | Just (True, hides) <- ideclHiding decl
+ , not (null hides)
+ , pRELUDE_NAME == unLoc (ideclName decl)
+ = return () -- Note [Do not warn about Prelude hiding]
| null used = addWarnAt loc msg1 -- Nothing used; drop entire decl
| null unused = return () -- Everything imported is used; nop
| otherwise = addWarnAt loc msg2 -- Some imports are unused
@@ -1452,6 +1458,19 @@ warnUnusedImport (L loc decl, used, unused)
pp_not_used = text "is redundant"
\end{code}
+Note [Do not warn about Prelude hiding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not warn about
+ import Prelude hiding( x, y )
+because even if nothing else from Prelude is used, it may be essential to hide
+x,y to avoid name-shadowing warnings. Example (Trac #9061)
+ import Prelude hiding( log )
+ f x = log where log = ()
+
+
+
+Note [Printing minimal imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To print the minimal imports we walk over the user-supplied import
decls, and simply trim their import lists. NB that
@@ -1462,6 +1481,7 @@ decls, and simply trim their import lists. NB that
\begin{code}
printMinimalImports :: [ImportDeclUsage] -> RnM ()
+-- See Note [Printing minimal imports]
printMinimalImports imports_w_usage
= do { imports' <- mapM mk_minimal imports_w_usage
; this_mod <- getModule
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 3c48f34032..48fffce374 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -10,13 +10,8 @@ general, all of these functions return a renamed thing, and a set of
free variables.
\begin{code}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -439,7 +434,7 @@ rnPatAndThen mk (PArrPat pats _)
rnPatAndThen mk (TuplePat pats boxed _)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
- ; return (TuplePat pats' boxed placeHolderType) }
+ ; return (TuplePat pats' boxed []) }
rnPatAndThen _ (SplicePat splice)
= do { -- XXX How to deal with free variables?
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index fbc22c0c28..9bc0e44780 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -4,6 +4,8 @@
\section[RnSource]{Main pass of renamer}
\begin{code}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+
module RnSource (
rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
) where
@@ -443,12 +445,14 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
+ , cid_overlap_mode = oflag
, cid_datafam_insts = adts })
-- Used for both source and interface file decls
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
, cid_sigs = [], cid_tyfam_insts = []
+ , cid_overlap_mode = oflag
, cid_datafam_insts = [] }
, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
@@ -461,7 +465,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
; ((ats', adts', other_sigs'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
- do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
+ do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
; return ( (ats', adts', other_sigs')
@@ -491,6 +495,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
`plusFV` inst_fvs
; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
+ , cid_overlap_mode = oflag
, cid_datafam_insts = adts' },
all_fvs) } } }
-- We return the renamed associated data type declarations so
@@ -559,14 +564,29 @@ rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn RdrName
-> RnM (TyFamInstEqn Name, FreeVars)
-rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon
- , tfie_pats = HsWB { hswb_cts = pats }
- , tfie_rhs = rhs })
+rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = HsWB { hswb_cts = pats }
+ , tfe_rhs = rhs })
= do { (tycon', pats', rhs', fvs) <-
rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
- ; return (TyFamInstEqn { tfie_tycon = tycon'
- , tfie_pats = pats'
- , tfie_rhs = rhs' }, fvs) }
+ ; return (TyFamEqn { tfe_tycon = tycon'
+ , tfe_pats = pats'
+ , tfe_rhs = rhs' }, fvs) }
+
+rnTyFamDefltEqn :: Name
+ -> TyFamDefltEqn RdrName
+ -> RnM (TyFamDefltEqn Name, FreeVars)
+rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
+ , tfe_pats = tyvars
+ , tfe_rhs = rhs })
+ = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
+ do { tycon' <- lookupFamInstName (Just cls) tycon
+ ; (rhs', fvs) <- rnLHsType ctx rhs
+ ; return (TyFamEqn { tfe_tycon = tycon'
+ , tfe_pats = tyvars'
+ , tfe_rhs = rhs' }, fvs) }
+ where
+ ctx = TyFamilyCtx tycon
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl RdrName
@@ -585,7 +605,7 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
Renaming of the associated types in instances.
\begin{code}
--- rename associated type family decl in class
+-- Rename associated type family decl in class
rnATDecls :: Name -- Class
-> [LFamilyDecl RdrName]
-> RnM ([LFamilyDecl Name], FreeVars)
@@ -635,11 +655,11 @@ extendTyVarEnvForMethodBinds ktv_names thing_inside
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
-rnSrcDerivDecl (DerivDecl ty)
+rnSrcDerivDecl (DerivDecl ty overlap)
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
- ; return (DerivDecl ty', fvs) }
+ ; return (DerivDecl ty' overlap, fvs) }
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -936,7 +956,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
do { (rhs', fvs) <- rnTySyn doc rhs
; return ((tyvars', rhs'), fvs) }
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
- , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
+ , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
@@ -961,20 +981,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- kind signatures on the tyvars
-- Tyvars scope over superclass context and method signatures
- ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
+ ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
<- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
- ; fds' <- rnFds (docOfHsDocContext cls_doc) fds
+ ; fds' <- rnFds fds
-- The fundeps have no free variables
; (ats', fv_ats) <- rnATDecls cls' ats
- ; (at_defs', fv_at_defs) <- rnATInstDecls rnTyFamInstDecl cls' tyvars' at_defs
; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
; let fvs = cxt_fvs `plusFV`
sig_fvs `plusFV`
- fv_ats `plusFV`
- fv_at_defs
- ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
+ fv_ats
+ ; return ((tyvars', context', fds', ats', sigs'), fvs) }
+
+ ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
-- No need to check for duplicate associated type decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
@@ -1006,7 +1026,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
- ; let all_fvs = meth_fvs `plusFV` stuff_fvs
+ ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
@@ -1404,21 +1424,20 @@ extendRecordFieldEnv tycl_decls inst_decls
%*********************************************************
\begin{code}
-rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
-
-rnFds doc fds
+rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
+rnFds fds
= mapM (wrapLocM rn_fds) fds
where
rn_fds (tys1, tys2)
- = do { tys1' <- rnHsTyVars doc tys1
- ; tys2' <- rnHsTyVars doc tys2
+ = do { tys1' <- rnHsTyVars tys1
+ ; tys2' <- rnHsTyVars tys2
; return (tys1', tys2') }
-rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
-rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs
+rnHsTyVars :: [RdrName] -> RnM [Name]
+rnHsTyVars tvs = mapM rnHsTyVar tvs
-rnHsTyVar :: SDoc -> RdrName -> RnM Name
-rnHsTyVar _doc tyvar = lookupOccRn tyvar
+rnHsTyVar :: RdrName -> RnM Name
+rnHsTyVar tyvar = lookupOccRn tyvar
\end{code}
diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs
index e0614d4248..3c0c145e6b 100644
--- a/compiler/rename/RnSplice.lhs
+++ b/compiler/rename/RnSplice.lhs
@@ -1,4 +1,6 @@
\begin{code}
+{-# LANGUAGE CPP #-}
+
module RnSplice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 23c54c3bed..2f9bfdd653 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -4,6 +4,8 @@
\section[RnSource]{Main pass of renamer}
\begin{code}
+{-# LANGUAGE CPP #-}
+
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
@@ -360,8 +362,9 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
, let (_, kvs) = extractHsTyRdrTyVars kind
, kv <- kvs ]
- all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
- nub (kv_bndrs ++ kvs_from_tv_bndrs)
+ all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
+ all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'
+
overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
-- These variables appear both as kind and type variables
-- in the same declaration; eg type family T (x :: *) (y :: x)
@@ -395,8 +398,12 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
- do { env <- getLocalRdrEnv
- ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
+ do { inner_rdr_env <- getLocalRdrEnv
+ ; traceRn (text "bhtv" <+> vcat
+ [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
+ , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
+ , ppr $ map (getUnique . rdrNameOcc) all_kvs'
+ , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
; return (res, fvs1 `plusFV` fvs2) } }
View Lorry Controller Status