summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in3
-rw-r--r--compiler/rename/RnBinds.hs4
-rw-r--r--compiler/rename/RnEnv.hs937
-rw-r--r--compiler/rename/RnExpr.hs6
-rw-r--r--compiler/rename/RnFixity.hs209
-rw-r--r--compiler/rename/RnNames.hs2
-rw-r--r--compiler/rename/RnPat.hs5
-rw-r--r--compiler/rename/RnSource.hs5
-rw-r--r--compiler/rename/RnSplice.hs2
-rw-r--r--compiler/rename/RnTypes.hs6
-rw-r--r--compiler/rename/RnUnbound.hs340
-rw-r--r--compiler/rename/RnUtils.hs410
-rw-r--r--compiler/typecheck/TcBackpack.hs2
-rw-r--r--compiler/typecheck/TcDeriv.hs1
-rw-r--r--compiler/typecheck/TcErrors.hs2
-rw-r--r--compiler/typecheck/TcExpr.hs4
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcRnExports.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs36
-rw-r--r--compiler/typecheck/TcSplice.hs2
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs3
-rw-r--r--compiler/typecheck/TcTyDecls.hs1
22 files changed, 1060 insertions, 924 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 6054d8579a..1c9c6c6b40 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -388,6 +388,9 @@ Library
RnSource
RnSplice
RnTypes
+ RnFixity
+ RnUtils
+ RnUnbound
CoreMonad
CSE
FloatIn
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 21d6095c27..9abeee207e 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -34,6 +34,10 @@ import RnTypes
import RnPat
import RnNames
import RnEnv
+import RnFixity
+import RnUtils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn
+ , checkDupRdrNames, warnUnusedLocalBinds
+ , checkDupAndShadowedNames, bindLocalNamesFV )
import DynFlags
import Module
import Name
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index a324ce42a8..3aa9472fe6 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1,7 +1,8 @@
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-2006
-\section[RnEnv]{Environment manipulation for the renamer monad}
+RnEnv contains functions which convert RdrNames into Names.
+
-}
{-# LANGUAGE CPP, MultiWayIf #-}
@@ -15,42 +16,26 @@ module RnEnv (
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
- reportUnboundName, unknownNameSuggestions,
- addNameClashErrRn,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
- lookupFixityRn, lookupFixityRn_help,
- lookupFieldFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
lookupConstructorFields,
+
+ lookupGreAvailRn,
+
+ -- Rebindable Syntax
lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
lookupIfThenElse,
- lookupGreAvailRn,
- mkUnboundName, mkUnboundNameRdr, isUnboundName,
+
+ -- Constructing usage information
addUsedGRE, addUsedGREs, addUsedDataCons,
- newLocalBndrRn, newLocalBndrsRn,
- bindLocalNames, bindLocalNamesFV,
- MiniFixityEnv,
- addLocalFixities,
- extendTyVarEnvFVRn,
-
- -- Role annotations
- RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
- lookupRoleAnnot, getRoleAnnots,
-
- checkDupRdrNames, checkShadowedRdrNames,
- checkDupNames, checkDupAndShadowedNames, dupNamesErr,
- checkTupSize,
- addFvRn, mapFvRn, mapMaybeFvRn,
- warnUnusedMatches, warnUnusedTypePatterns,
- warnUnusedTopBinds, warnUnusedLocalBinds,
- mkFieldEnv,
- dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
- HsDocContext(..), pprHsDocContext,
- inHsDocContext, withHsDocContext
+
+
+ dataTcOccs, --TODO: Move this somewhere, into utils?
+
) where
#include "HsVersions.h"
@@ -72,24 +57,21 @@ import Module
import ConLike
import DataCon
import TyCon
-import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
+import PrelNames ( rOOT_MAIN )
import ErrUtils ( MsgDoc )
-import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence,
- defaultFixity, pprWarningTxtForMsg, SourceText(..) )
+import BasicTypes ( pprWarningTxtForMsg )
import SrcLoc
import Outputable
import Util
import Maybes
import BasicTypes ( TopLevelFlag(..) )
-import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
-import Data.List
-import Data.Function ( on )
import ListSetOps ( minusList )
-import Constants ( mAX_TUPLE_SIZE )
import qualified GHC.LanguageExtensions as LangExt
+import RnUnbound
+import RnUtils
{-
*********************************************************
@@ -659,8 +641,6 @@ we'll miss the fact that the qualified import is redundant.
--------------------------------------------------
-}
-mkUnboundNameRdr :: RdrName -> Name
-mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
lookupLocatedOccRn = wrapLocM lookupOccRn
@@ -1378,216 +1358,8 @@ the list type constructor.
Note that setRdrNameSpace on an Exact name requires the Name to be External,
which it always is for built in syntax.
-
-*********************************************************
-* *
- Fixities
-* *
-*********************************************************
-
-Note [Fixity signature lookup]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A fixity declaration like
-
- infixr 2 ?
-
-can refer to a value-level operator, e.g.:
-
- (?) :: String -> String -> String
-
-or a type-level operator, like:
-
- data (?) a b = A a | B b
-
-so we extend the lookup of the reader name '?' to the TcClsName namespace, as
-well as the original namespace.
-
-The extended lookup is also used in other places, like resolution of
-deprecation declarations, and lookup of names in GHCi.
--}
-
---------------------------------
-type MiniFixityEnv = FastStringEnv (Located Fixity)
- -- Mini fixity env for the names we're about
- -- to bind, in a single binding group
- --
- -- It is keyed by the *FastString*, not the *OccName*, because
- -- the single fixity decl infix 3 T
- -- affects both the data constructor T and the type constrctor T
- --
- -- We keep the location so that if we find
- -- a duplicate, we can report it sensibly
-
---------------------------------
--- Used for nested fixity decls to bind names along with their fixities.
--- the fixities are given as a UFM from an OccName's FastString to a fixity decl
-
-addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
-addLocalFixities mini_fix_env names thing_inside
- = extendFixityEnv (mapMaybe find_fixity names) thing_inside
- where
- find_fixity name
- = case lookupFsEnv mini_fix_env (occNameFS occ) of
- Just (L _ fix) -> Just (name, FixItem occ fix)
- Nothing -> Nothing
- where
- occ = nameOccName name
-
-{-
---------------------------------
-lookupFixity is a bit strange.
-
-* Nested local fixity decls are put in the local fixity env, which we
- find with getFixtyEnv
-
-* Imported fixities are found in the PIT
-
-* Top-level fixity decls in this module may be for Names that are
- either Global (constructors, class operations)
- or Local/Exported (everything else)
- (See notes with RnNames.getLocalDeclBinders for why we have this split.)
- We put them all in the local fixity environment
-}
-lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name = lookupFixityRn' name (nameOccName name)
-
-lookupFixityRn' :: Name -> OccName -> RnM Fixity
-lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
-
--- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
--- in a local environment or from an interface file. Otherwise, it returns
--- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
--- user-supplied fixity declarations).
-lookupFixityRn_help :: Name
- -> RnM (Bool, Fixity)
-lookupFixityRn_help name =
- lookupFixityRn_help' name (nameOccName name)
-
-lookupFixityRn_help' :: Name
- -> OccName
- -> RnM (Bool, Fixity)
-lookupFixityRn_help' name occ
- | isUnboundName name
- = return (False, Fixity NoSourceText minPrecedence InfixL)
- -- Minimise errors from ubound names; eg
- -- a>0 `foo` b>0
- -- where 'foo' is not in scope, should not give an error (Trac #7937)
-
- | otherwise
- = do { local_fix_env <- getFixityEnv
- ; case lookupNameEnv local_fix_env name of {
- Just (FixItem _ fix) -> return (True, fix) ;
- Nothing ->
-
- do { this_mod <- getModule
- ; if nameIsLocalOrFrom this_mod name
- -- Local (and interactive) names are all in the
- -- fixity env, and don't have entries in the HPT
- then return (False, defaultFixity)
- else lookup_imported } } }
- where
- lookup_imported
- -- For imported names, we have to get their fixities by doing a
- -- loadInterfaceForName, and consulting the Ifaces that comes back
- -- from that, because the interface file for the Name might not
- -- have been loaded yet. Why not? Suppose you import module A,
- -- which exports a function 'f', thus;
- -- module CurrentModule where
- -- import A( f )
- -- module A( f ) where
- -- import B( f )
- -- Then B isn't loaded right away (after all, it's possible that
- -- nothing from B will be used). When we come across a use of
- -- 'f', we need to know its fixity, and it's then, and only
- -- then, that we load B.hi. That is what's happening here.
- --
- -- loadInterfaceForName will find B.hi even if B is a hidden module,
- -- and that's what we want.
- = do { iface <- loadInterfaceForName doc name
- ; let mb_fix = mi_fix_fn iface occ
- ; let msg = case mb_fix of
- Nothing ->
- text "looking up name" <+> ppr name
- <+> text "in iface, but found no fixity for it."
- <+> text "Using default fixity instead."
- Just f ->
- text "looking up name in iface and found:"
- <+> vcat [ppr name, ppr f]
- ; traceRn "lookupFixityRn_either:" msg
- ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) }
-
- doc = text "Checking fixity for" <+> ppr name
-
----------------
-lookupTyFixityRn :: Located Name -> RnM Fixity
-lookupTyFixityRn (L _ n) = lookupFixityRn n
-
--- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
--- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
--- the field label, which might be different to the 'OccName' of the selector
--- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
--- multiple possible selectors with different fixities, generate an error.
-lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
-lookupFieldFixityRn (Unambiguous (L _ rdr) n)
- = lookupFixityRn' n (rdrNameOcc rdr)
-lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
- where
- get_ambiguous_fixity :: RdrName -> RnM Fixity
- get_ambiguous_fixity rdr_name = do
- traceRn "get_ambiguous_fixity" (ppr rdr_name)
- rdr_env <- getGlobalRdrEnv
- let elts = lookupGRE_RdrName rdr_name rdr_env
-
- fixities <- groupBy ((==) `on` snd) . zip elts
- <$> mapM lookup_gre_fixity elts
-
- case fixities of
- -- There should always be at least one fixity.
- -- Something's very wrong if there are no fixity candidates, so panic
- [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
- [ (_, fix):_ ] -> return fix
- ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
- >> return (Fixity NoSourceText minPrecedence InfixL)
-
- lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
-
- ambiguous_fixity_err rn ambigs
- = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
- , hang (text "Conflicts: ") 2 . vcat .
- map format_ambig $ concat ambigs ]
-
- format_ambig (elt, fix) = hang (ppr fix)
- 2 (pprNameProvenance elt)
-
-
-{- *********************************************************************
-* *
- Role annotations
-* *
-********************************************************************* -}
-
-type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name)
-
-mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv
-mkRoleAnnotEnv role_annot_decls
- = mkNameEnv [ (name, ra_decl)
- | ra_decl <- role_annot_decls
- , let name = roleAnnotDeclName (unLoc ra_decl)
- , not (isUnboundName name) ]
- -- Some of the role annots will be unbound;
- -- we don't wish to include these
-
-emptyRoleAnnotEnv :: RoleAnnotEnv
-emptyRoleAnnotEnv = emptyNameEnv
-
-lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name)
-lookupRoleAnnot = lookupNameEnv
-
-getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv)
-getRoleAnnots bndrs role_env
- = ( mapMaybe (lookupRoleAnnot role_env) bndrs
- , delListFromNameEnv role_env bndrs )
{-
@@ -1675,682 +1447,15 @@ lookupSyntaxNames std_names
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }
-{-
-*********************************************************
-* *
-\subsection{Binding}
-* *
-*********************************************************
--}
-
-newLocalBndrRn :: Located RdrName -> RnM Name
--- Used for non-top-level binders. These should
--- never be qualified.
-newLocalBndrRn (L loc rdr_name)
- | Just name <- isExact_maybe rdr_name
- = return name -- This happens in code generated by Template Haskell
- -- See Note [Binders in Template Haskell] in Convert.hs
- | otherwise
- = do { unless (isUnqual rdr_name)
- (addErrAt loc (badQualBndrErr rdr_name))
- ; uniq <- newUnique
- ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
-
-newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
-newLocalBndrsRn = mapM newLocalBndrRn
+-- Error messages
-bindLocalNames :: [Name] -> RnM a -> RnM a
-bindLocalNames names enclosed_scope
- = do { lcl_env <- getLclEnv
- ; let th_level = thLevel (tcl_th_ctxt lcl_env)
- th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
- [ (n, (NotTopLevel, th_level)) | n <- names ]
- rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
- ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
- , tcl_rdr = rdr_env' })
- enclosed_scope }
-
-bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV names enclosed_scope
- = do { (result, fvs) <- bindLocalNames names enclosed_scope
- ; return (result, delFVs names fvs) }
-
--------------------------------------
-
-extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
- -- This function is used only in rnSourceDecl on InstDecl
-extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
-
--------------------------------------
-checkDupRdrNames :: [Located RdrName] -> RnM ()
--- Check for duplicated names in a binding group
-checkDupRdrNames rdr_names_w_loc
- = mapM_ (dupNamesErr getLoc) dups
- where
- (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
-
-checkDupNames :: [Name] -> RnM ()
--- Check for duplicated names in a binding group
-checkDupNames names = check_dup_names (filterOut isSystemName names)
- -- See Note [Binders in Template Haskell] in Convert
-
-check_dup_names :: [Name] -> RnM ()
-check_dup_names names
- = mapM_ (dupNamesErr nameSrcSpan) dups
- where
- (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
-
----------------------
-checkShadowedRdrNames :: [Located RdrName] -> RnM ()
-checkShadowedRdrNames loc_rdr_names
- = do { envs <- getRdrEnvs
- ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
- where
- filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
- -- See Note [Binders in Template Haskell] in Convert
- get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)
-
-checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
-checkDupAndShadowedNames envs names
- = do { check_dup_names filtered_names
- ; checkShadowedOccs envs get_loc_occ filtered_names }
- where
- filtered_names = filterOut isSystemName names
- -- See Note [Binders in Template Haskell] in Convert
- get_loc_occ name = (nameSrcSpan name, nameOccName name)
-
--------------------------------------
-checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
- -> (a -> (SrcSpan, OccName))
- -> [a] -> RnM ()
-checkShadowedOccs (global_env,local_env) get_loc_occ ns
- = whenWOptM Opt_WarnNameShadowing $
- do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
- ; mapM_ check_shadow ns }
- where
- check_shadow n
- | startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
- -- See Trac #3262
- | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
- | otherwise = do { gres' <- filterM is_shadowed_gre gres
- ; complain (map pprNameProvenance gres') }
- where
- (loc,occ) = get_loc_occ n
- mb_local = lookupLocalRdrOcc local_env occ
- gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
- -- Make an Unqualified RdrName and look that up, so that
- -- we don't find any GREs that are in scope qualified-only
-
- complain [] = return ()
- complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
- loc
- (shadowedNameWarn occ pp_locs)
-
- is_shadowed_gre :: GlobalRdrElt -> RnM Bool
- -- Returns False for record selectors that are shadowed, when
- -- punning or wild-cards are on (cf Trac #2723)
- is_shadowed_gre gre | isRecFldGRE gre
- = do { dflags <- getDynFlags
- ; return $ not (xopt LangExt.RecordPuns dflags
- || xopt LangExt.RecordWildCards dflags) }
- is_shadowed_gre _other = return True
-
-{-
-************************************************************************
-* *
- What to do when a lookup fails
-* *
-************************************************************************
--}
-
-data WhereLooking = WL_Any -- Any binding
- | WL_Global -- Any top-level binding (local or imported)
- | WL_LocalTop -- Any top-level binding in this module
- | WL_LocalOnly
- -- Only local bindings
- -- (pattern synonyms declaractions,
- -- see Note [Renaming pattern synonym variables])
-
-reportUnboundName :: RdrName -> RnM Name
-reportUnboundName rdr = unboundName WL_Any rdr
-
-unboundName :: WhereLooking -> RdrName -> RnM Name
-unboundName wl rdr = unboundNameX wl rdr Outputable.empty
-
-unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
-unboundNameX where_look rdr_name extra
- = do { dflags <- getDynFlags
- ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
- what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
- err = unknownNameErr what rdr_name $$ extra
- ; if not show_helpful_errors
- then addErr err
- else do { local_env <- getLocalRdrEnv
- ; global_env <- getGlobalRdrEnv
- ; impInfo <- getImports
- ; let suggestions = unknownNameSuggestions_ where_look
- dflags global_env local_env impInfo rdr_name
- ; addErr (err $$ suggestions) }
- ; return (mkUnboundNameRdr rdr_name) }
-
-unknownNameErr :: SDoc -> RdrName -> SDoc
-unknownNameErr what rdr_name
- = vcat [ hang (text "Not in scope:")
- 2 (what <+> quotes (ppr rdr_name))
- , extra ]
- where
- extra | rdr_name == forall_tv_RDR = perhapsForallMsg
- | otherwise = Outputable.empty
-
-type HowInScope = Either SrcSpan ImpDeclSpec
- -- Left loc => locally bound at loc
- -- Right ispec => imported as specified by ispec
-
-
--- | Called from the typechecker (TcErrors) when we find an unbound variable
-unknownNameSuggestions :: DynFlags
- -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
- -> RdrName -> SDoc
-unknownNameSuggestions = unknownNameSuggestions_ WL_Any
-
-unknownNameSuggestions_ :: WhereLooking -> DynFlags
- -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
- -> RdrName -> SDoc
-unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =
- similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
- importSuggestions where_look imports tried_rdr_name $$
- extensionSuggestions tried_rdr_name
-
-
-similarNameSuggestions :: WhereLooking -> DynFlags
- -> GlobalRdrEnv -> LocalRdrEnv
- -> RdrName -> SDoc
-similarNameSuggestions where_look dflags global_env
- local_env tried_rdr_name
- = case suggest of
- [] -> Outputable.empty
- [p] -> perhaps <+> pp_item p
- ps -> sep [ perhaps <+> text "one of these:"
- , nest 2 (pprWithCommas pp_item ps) ]
- where
- all_possibilities :: [(String, (RdrName, HowInScope))]
- all_possibilities
- = [ (showPpr dflags r, (r, Left loc))
- | (r,loc) <- local_possibilities local_env ]
- ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
-
- suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
- perhaps = text "Perhaps you meant"
-
- pp_item :: (RdrName, HowInScope) -> SDoc
- 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 (text "line" <+> int (srcSpanStartLine l))
- pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported
- parens (text "imported from" <+> ppr (is_mod is))
-
- pp_ns :: RdrName -> SDoc
- pp_ns rdr | ns /= tried_ns = pprNameSpace ns
- | otherwise = Outputable.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 = nameSpacesRelated (occNameSpace occ) tried_ns
- && isSymOcc occ == tried_is_sym
- -- Treat operator and non-operators as non-matching
- -- This heuristic avoids things like
- -- Not in scope 'f'; perhaps you meant '+' (from Prelude)
-
- local_ok = case where_look of { WL_Any -> True
- ; WL_LocalOnly -> True
- ; _ -> False }
- local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
- local_possibilities env
- | tried_is_qual = []
- | not local_ok = []
- | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name)
- | name <- localRdrEnvElts env
- , let occ = nameOccName name
- , correct_name_space occ]
-
- gre_ok :: GlobalRdrElt -> Bool
- gre_ok = case where_look of
- WL_LocalTop -> isLocalGRE
- WL_LocalOnly -> const False
- _ -> const True
-
- global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
- global_possibilities global_env
- | tried_is_qual = [ (rdr_qual, (rdr_qual, how))
- | gre <- globalRdrEnvElts global_env
- , gre_ok gre
- , let name = gre_name gre
- occ = nameOccName name
- , correct_name_space occ
- , (mod, how) <- quals_in_scope gre
- , let rdr_qual = mkRdrQual mod occ ]
-
- | otherwise = [ (rdr_unqual, pair)
- | gre <- globalRdrEnvElts global_env
- , gre_ok gre
- , let name = gre_name gre
- occ = nameOccName name
- rdr_unqual = mkRdrUnqual occ
- , correct_name_space occ
- , pair <- case (unquals_in_scope gre, quals_only gre) of
- (how:_, _) -> [ (rdr_unqual, how) ]
- ([], pr:_) -> [ pr ] -- See Note [Only-quals]
- ([], []) -> [] ]
-
- -- Note [Only-quals]
- -- The second alternative returns those names with the same
- -- OccName as the one we tried, but live in *qualified* imports
- -- e.g. if you have:
- --
- -- > import qualified Data.Map as Map
- -- > foo :: Map
- --
- -- then we suggest @Map.Map@.
-
- --------------------
- unquals_in_scope :: GlobalRdrElt -> [HowInScope]
- unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
- | lcl = [ Left (nameSrcSpan n) ]
- | otherwise = [ Right ispec
- | i <- is, let ispec = is_decl i
- , not (is_qual ispec) ]
-
- --------------------
- quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
- -- Ones for which the qualified version is in scope
- quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
- | lcl = case nameModule_maybe n of
- Nothing -> []
- Just m -> [(moduleName m, Left (nameSrcSpan n))]
- | otherwise = [ (is_as ispec, Right ispec)
- | i <- is, let ispec = is_decl i ]
-
- --------------------
- quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]
- -- Ones for which *only* the qualified version is in scope
- quals_only (GRE { gre_name = n, gre_imp = is })
- = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)
- | i <- is, let ispec = is_decl i, is_qual ispec ]
-
--- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.
-importSuggestions :: WhereLooking -> ImportAvails -> RdrName -> SDoc
-importSuggestions where_look imports rdr_name
- | WL_LocalOnly <- where_look = Outputable.empty
- | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
- | null interesting_imports
- , Just name <- mod_name
- = hsep
- [ text "No module named"
- , quotes (ppr name)
- , text "is imported."
- ]
- | is_qualified
- , null helpful_imports
- , [(mod,_)] <- interesting_imports
- = hsep
- [ text "Module"
- , quotes (ppr mod)
- , text "does not export"
- , quotes (ppr occ_name) <> dot
- ]
- | is_qualified
- , null helpful_imports
- , mods <- map fst interesting_imports
- = hsep
- [ text "Neither"
- , quotedListWithNor (map ppr mods)
- , text "exports"
- , quotes (ppr occ_name) <> dot
- ]
- | [(mod,imv)] <- helpful_imports_non_hiding
- = fsep
- [ text "Perhaps you want to add"
- , quotes (ppr occ_name)
- , text "to the import list"
- , text "in the import of"
- , quotes (ppr mod)
- , parens (ppr (imv_span imv)) <> dot
- ]
- | not (null helpful_imports_non_hiding)
- = fsep
- [ text "Perhaps you want to add"
- , quotes (ppr occ_name)
- , text "to one of these import lists:"
- ]
- $$
- nest 2 (vcat
- [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
- | (mod,imv) <- helpful_imports_non_hiding
- ])
- | [(mod,imv)] <- helpful_imports_hiding
- = fsep
- [ text "Perhaps you want to remove"
- , quotes (ppr occ_name)
- , text "from the explicit hiding list"
- , text "in the import of"
- , quotes (ppr mod)
- , parens (ppr (imv_span imv)) <> dot
- ]
- | not (null helpful_imports_hiding)
- = fsep
- [ text "Perhaps you want to remove"
- , quotes (ppr occ_name)
- , text "from the hiding clauses"
- , text "in one of these imports:"
- ]
- $$
- nest 2 (vcat
- [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
- | (mod,imv) <- helpful_imports_hiding
- ])
- | otherwise
- = Outputable.empty
- where
- is_qualified = isQual rdr_name
- (mod_name, occ_name) = case rdr_name of
- Unqual occ_name -> (Nothing, occ_name)
- Qual mod_name occ_name -> (Just mod_name, occ_name)
- _ -> error "importSuggestions: dead code"
-
-
- -- What import statements provide "Mod" at all
- -- or, if this is an unqualified name, are not qualified imports
- interesting_imports = [ (mod, imp)
- | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
- , Just imp <- return $ pick (importedByUser mod_imports)
- ]
-
- -- We want to keep only one for each original module; preferably one with an
- -- explicit import list (for no particularly good reason)
- pick :: [ImportedModsVal] -> Maybe ImportedModsVal
- pick = listToMaybe . sortBy (compare `on` prefer) . filter select
- where select imv = case mod_name of Just name -> imv_name imv == name
- Nothing -> not (imv_qualified imv)
- prefer imv = (imv_is_hiding imv, imv_span imv)
-
- -- Which of these would export a 'foo'
- -- (all of these are restricted imports, because if they were not, we
- -- wouldn't have an out-of-scope error in the first place)
- helpful_imports = filter helpful interesting_imports
- where helpful (_,imv)
- = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name
-
- -- Which of these do that because of an explicit hiding list resp. an
- -- explicit import list
- (helpful_imports_hiding, helpful_imports_non_hiding)
- = partition (imv_is_hiding . snd) helpful_imports
-
-extensionSuggestions :: RdrName -> SDoc
-extensionSuggestions rdrName
- | rdrName == mkUnqual varName (fsLit "mdo") ||
- rdrName == mkUnqual varName (fsLit "rec")
- = text "Perhaps you meant to use RecursiveDo"
- | otherwise = Outputable.empty
-
-{-
-************************************************************************
-* *
-\subsection{Free variable manipulation}
-* *
-************************************************************************
--}
-
--- A useful utility
-addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
-addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
- ; return (res, fvs1 `plusFV` fvs2) }
-
-mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
-mapFvRn f xs = do stuff <- mapM f xs
- case unzip stuff of
- (ys, fvs_s) -> return (ys, plusFVs fvs_s)
-
-mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
-mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
-mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
-
-{-
-************************************************************************
-* *
-\subsection{Envt utility functions}
-* *
-************************************************************************
--}
-
-warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
-warnUnusedTopBinds gres
- = whenWOptM Opt_WarnUnusedTopBinds
- $ do env <- getGblEnv
- let isBoot = tcg_src env == HsBootFile
- let noParent gre = case gre_par gre of
- NoParent -> True
- _ -> False
- -- Don't warn about unused bindings with parents in
- -- .hs-boot files, as you are sometimes required to give
- -- unused bindings (trac #3449).
- -- HOWEVER, in a signature file, you are never obligated to put a
- -- definition in the main text. Thus, if you define something
- -- and forget to export it, we really DO want to warn.
- gres' = if isBoot then filter noParent gres
- else gres
- warnUnusedGREs gres'
-
-warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
- :: [Name] -> FreeVars -> RnM ()
-warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
-warnUnusedMatches = check_unused Opt_WarnUnusedMatches
-warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
-
-check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
-check_unused flag bound_names used_names
- = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
- bound_names))
-
--------------------------
--- Helpers
-warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
-warnUnusedGREs gres = mapM_ warnUnusedGRE gres
-
-warnUnused :: WarningFlag -> [Name] -> RnM ()
-warnUnused flag names = do
- fld_env <- mkFieldEnv <$> getGlobalRdrEnv
- mapM_ (warnUnused1 flag fld_env) names
-
-warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
-warnUnused1 flag fld_env name
- = when (reportable name occ) $
- addUnusedWarning flag
- occ (nameSrcSpan name)
- (text "Defined but not used")
- where
- occ = case lookupNameEnv fld_env name of
- Just (fl, _) -> mkVarOccFS fl
- Nothing -> nameOccName name
-
-warnUnusedGRE :: GlobalRdrElt -> RnM ()
-warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
- | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
- warnUnused1 Opt_WarnUnusedTopBinds fld_env name
- | otherwise = when (reportable name occ) (mapM_ warn is)
- where
- occ = greOccName gre
- warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
- where
- span = importSpecLoc spec
- pp_mod = quotes (ppr (importSpecModule spec))
- msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
-
--- | Make a map from selector names to field labels and parent tycon
--- names, to be used when reporting unused record fields.
-mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
-mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
- | gres <- occEnvElts rdr_env
- , gre <- gres
- , Just lbl <- [greLabel gre]
- ]
-
--- | Should we report the fact that this 'Name' is unused? The
--- 'OccName' may differ from 'nameOccName' due to
--- DuplicateRecordFields.
-reportable :: Name -> OccName -> Bool
-reportable name occ
- | isWiredInName name = False -- Don't report unused wired-in names
- -- Otherwise we get a zillion warnings
- -- from Data.Tuple
- | otherwise = not (startsWithUnderscore occ)
-
-addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning flag occ span msg
- = addWarnAt (Reason flag) span $
- sep [msg <> colon,
- nest 2 $ pprNonVarNameSpace (occNameSpace occ)
- <+> quotes (ppr occ)]
-
-addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
-addNameClashErrRn rdr_name gres
- | all isLocalGRE gres && not (all isRecFldGRE gres)
- -- If there are two or more *local* defns, we'll have reported
- = return () -- that already, and we don't want an error cascade
- | otherwise
- = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
- text "It could refer to" <+> vcat (msg1 : msgs)])
- where
- (np1:nps) = gres
- msg1 = ptext (sLit "either") <+> mk_ref np1
- msgs = [text " or" <+> mk_ref np | np <- nps]
- mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
- where nom = case gre_par gre of
- FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
- _ -> quotes (ppr (gre_name gre))
-
-shadowedNameWarn :: OccName -> [SDoc] -> SDoc
-shadowedNameWarn occ shadowed_locs
- = sep [text "This binding for" <+> quotes (ppr occ)
- <+> text "shadows the existing binding" <> plural shadowed_locs,
- nest 2 (vcat shadowed_locs)]
-
-perhapsForallMsg :: SDoc
-perhapsForallMsg
- = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"
- , text "to enable explicit-forall syntax: forall <tvs>. <type>"]
-
-unknownSubordinateErr :: SDoc -> RdrName -> SDoc
-unknownSubordinateErr doc op -- Doc is "method of class" or
- -- "field of constructor"
- = quotes (ppr op) <+> text "is not a (visible)" <+> doc
-
-badOrigBinding :: RdrName -> SDoc
-badOrigBinding name
- = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
- -- The rdrNameOcc is because we don't want to print Prelude.(,)
-
-dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
-dupNamesErr get_loc names
- = addErrAt big_loc $
- vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
- locations]
- where
- locs = map get_loc names
- big_loc = foldr1 combineSrcSpans locs
- locations = text "Bound at:" <+> vcat (map ppr (sort locs))
-
-kindSigErr :: Outputable a => a -> SDoc
-kindSigErr thing
- = hang (text "Illegal kind signature for" <+> quotes (ppr thing))
- 2 (text "Perhaps you intended to use KindSignatures")
-
-badQualBndrErr :: RdrName -> SDoc
-badQualBndrErr rdr_name
- = text "Qualified name in binding position:" <+> ppr rdr_name
opDeclErr :: RdrName -> SDoc
opDeclErr n
= hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
2 (text "Use TypeOperators to declare operators in type and declarations")
-checkTupSize :: Int -> RnM ()
-checkTupSize tup_size
- | tup_size <= mAX_TUPLE_SIZE
- = return ()
- | otherwise
- = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
- nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
- nest 2 (text "Workaround: use nested tuples or define a data type")])
-
-{-
-************************************************************************
-* *
-\subsection{Contexts for renaming errors}
-* *
-************************************************************************
--}
-
--- AZ:TODO: Change these all to be Name instead of RdrName.
--- Merge TcType.UserTypeContext in to it.
-data HsDocContext
- = TypeSigCtx SDoc
- | PatCtx
- | SpecInstSigCtx
- | DefaultDeclCtx
- | ForeignDeclCtx (Located RdrName)
- | DerivDeclCtx
- | RuleCtx FastString
- | TyDataCtx (Located RdrName)
- | TySynCtx (Located RdrName)
- | TyFamilyCtx (Located RdrName)
- | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance
- | ConDeclCtx [Located Name]
- | ClassDeclCtx (Located RdrName)
- | ExprWithTySigCtx
- | TypBrCtx
- | HsTypeCtx
- | GHCiCtx
- | SpliceTypeCtx (LHsType RdrName)
- | ClassInstanceCtx
- | VectDeclCtx (Located RdrName)
- | GenericCtx SDoc -- Maybe we want to use this more!
-
-withHsDocContext :: HsDocContext -> SDoc -> SDoc
-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
-
-inHsDocContext :: HsDocContext -> SDoc
-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
-
-pprHsDocContext :: HsDocContext -> SDoc
-pprHsDocContext (GenericCtx doc) = doc
-pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc
-pprHsDocContext PatCtx = text "a pattern type-signature"
-pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
-pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
-pprHsDocContext DerivDeclCtx = text "a deriving declaration"
-pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name
-pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
-pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
-pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
-pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name)
-pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name)
-pprHsDocContext ExprWithTySigCtx = text "an expression type signature"
-pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type"
-pprHsDocContext HsTypeCtx = text "a type argument"
-pprHsDocContext GHCiCtx = text "GHCi input"
-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
-pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances"
-
-pprHsDocContext (ForeignDeclCtx name)
- = text "the foreign declaration for" <+> quotes (ppr name)
-pprHsDocContext (ConDeclCtx [name])
- = text "the definition of data constructor" <+> quotes (ppr name)
-pprHsDocContext (ConDeclCtx names)
- = text "the definition of data constructors" <+> interpp'SP names
-pprHsDocContext (VectDeclCtx tycon)
- = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
+badOrigBinding :: RdrName -> SDoc
+badOrigBinding name
+ = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
+ -- The rdrNameOcc is because we don't want to print Prelude.(,)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 4e9192c26e..987b0bec49 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -26,6 +26,12 @@ import HsSyn
import TcRnMonad
import Module ( getModule )
import RnEnv
+import RnFixity
+import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
+ , bindLocalNames
+ , mapMaybeFvRn, mapFvRn
+ , warnUnusedLocalBinds )
+import RnUnbound ( reportUnboundName )
import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes
import RnPat
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
new file mode 100644
index 0000000000..61566f0ba5
--- /dev/null
+++ b/compiler/rename/RnFixity.hs
@@ -0,0 +1,209 @@
+{-
+
+This module contains code which maintains and manipulates the
+fixity environment during renaming.
+
+-}
+module RnFixity ( MiniFixityEnv,
+ addLocalFixities,
+ lookupFixityRn, lookupFixityRn_help,
+ lookupFieldFixityRn, lookupTyFixityRn ) where
+
+import LoadIface
+import HsSyn
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import NameEnv
+import Module
+import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence,
+ defaultFixity, SourceText(..) )
+import SrcLoc
+import Outputable
+import Maybes
+import Data.List
+import Data.Function ( on )
+import RnUnbound
+
+{-
+*********************************************************
+* *
+ Fixities
+* *
+*********************************************************
+
+Note [Fixity signature lookup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A fixity declaration like
+
+ infixr 2 ?
+
+can refer to a value-level operator, e.g.:
+
+ (?) :: String -> String -> String
+
+or a type-level operator, like:
+
+ data (?) a b = A a | B b
+
+so we extend the lookup of the reader name '?' to the TcClsName namespace, as
+well as the original namespace.
+
+The extended lookup is also used in other places, like resolution of
+deprecation declarations, and lookup of names in GHCi.
+-}
+
+--------------------------------
+type MiniFixityEnv = FastStringEnv (Located Fixity)
+ -- Mini fixity env for the names we're about
+ -- to bind, in a single binding group
+ --
+ -- It is keyed by the *FastString*, not the *OccName*, because
+ -- the single fixity decl infix 3 T
+ -- affects both the data constructor T and the type constrctor T
+ --
+ -- We keep the location so that if we find
+ -- a duplicate, we can report it sensibly
+
+--------------------------------
+-- Used for nested fixity decls to bind names along with their fixities.
+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
+
+addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
+addLocalFixities mini_fix_env names thing_inside
+ = extendFixityEnv (mapMaybe find_fixity names) thing_inside
+ where
+ find_fixity name
+ = case lookupFsEnv mini_fix_env (occNameFS occ) of
+ Just (L _ fix) -> Just (name, FixItem occ fix)
+ Nothing -> Nothing
+ where
+ occ = nameOccName name
+
+{-
+--------------------------------
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+ find with getFixtyEnv
+
+* Imported fixities are found in the PIT
+
+* Top-level fixity decls in this module may be for Names that are
+ either Global (constructors, class operations)
+ or Local/Exported (everything else)
+ (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+ We put them all in the local fixity environment
+-}
+
+lookupFixityRn :: Name -> RnM Fixity
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
+
+-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
+-- in a local environment or from an interface file. Otherwise, it returns
+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
+-- user-supplied fixity declarations).
+lookupFixityRn_help :: Name
+ -> RnM (Bool, Fixity)
+lookupFixityRn_help name =
+ lookupFixityRn_help' name (nameOccName name)
+
+lookupFixityRn_help' :: Name
+ -> OccName
+ -> RnM (Bool, Fixity)
+lookupFixityRn_help' name occ
+ | isUnboundName name
+ = return (False, Fixity NoSourceText minPrecedence InfixL)
+ -- Minimise errors from ubound names; eg
+ -- a>0 `foo` b>0
+ -- where 'foo' is not in scope, should not give an error (Trac #7937)
+
+ | otherwise
+ = do { local_fix_env <- getFixityEnv
+ ; case lookupNameEnv local_fix_env name of {
+ Just (FixItem _ fix) -> return (True, fix) ;
+ Nothing ->
+
+ do { this_mod <- getModule
+ ; if nameIsLocalOrFrom this_mod name
+ -- Local (and interactive) names are all in the
+ -- fixity env, and don't have entries in the HPT
+ then return (False, defaultFixity)
+ else lookup_imported } } }
+ where
+ lookup_imported
+ -- For imported names, we have to get their fixities by doing a
+ -- loadInterfaceForName, and consulting the Ifaces that comes back
+ -- from that, because the interface file for the Name might not
+ -- have been loaded yet. Why not? Suppose you import module A,
+ -- which exports a function 'f', thus;
+ -- module CurrentModule where
+ -- import A( f )
+ -- module A( f ) where
+ -- import B( f )
+ -- Then B isn't loaded right away (after all, it's possible that
+ -- nothing from B will be used). When we come across a use of
+ -- 'f', we need to know its fixity, and it's then, and only
+ -- then, that we load B.hi. That is what's happening here.
+ --
+ -- loadInterfaceForName will find B.hi even if B is a hidden module,
+ -- and that's what we want.
+ = do { iface <- loadInterfaceForName doc name
+ ; let mb_fix = mi_fix_fn iface occ
+ ; let msg = case mb_fix of
+ Nothing ->
+ text "looking up name" <+> ppr name
+ <+> text "in iface, but found no fixity for it."
+ <+> text "Using default fixity instead."
+ Just f ->
+ text "looking up name in iface and found:"
+ <+> vcat [ppr name, ppr f]
+ ; traceRn "lookupFixityRn_either:" msg
+ ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) }
+
+ doc = text "Checking fixity for" <+> ppr name
+
+---------------
+lookupTyFixityRn :: Located Name -> RnM Fixity
+lookupTyFixityRn (L _ n) = lookupFixityRn n
+
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
+-- multiple possible selectors with different fixities, generate an error.
+lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
+lookupFieldFixityRn (Unambiguous (L _ rdr) n)
+ = lookupFixityRn' n (rdrNameOcc rdr)
+lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
+ where
+ get_ambiguous_fixity :: RdrName -> RnM Fixity
+ get_ambiguous_fixity rdr_name = do
+ traceRn "get_ambiguous_fixity" (ppr rdr_name)
+ rdr_env <- getGlobalRdrEnv
+ let elts = lookupGRE_RdrName rdr_name rdr_env
+
+ fixities <- groupBy ((==) `on` snd) . zip elts
+ <$> mapM lookup_gre_fixity elts
+
+ case fixities of
+ -- There should always be at least one fixity.
+ -- Something's very wrong if there are no fixity candidates, so panic
+ [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+ [ (_, fix):_ ] -> return fix
+ ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+ >> return (Fixity NoSourceText minPrecedence InfixL)
+
+ lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+ ambiguous_fixity_err rn ambigs
+ = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+ , hang (text "Conflicts: ") 2 . vcat .
+ map format_ambig $ concat ambigs ]
+
+ format_ambig (elt, fix) = hang (ppr fix)
+ 2 (pprNameProvenance elt)
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index eccd728db4..fa5f24fb46 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -24,6 +24,8 @@ import DynFlags
import HsSyn
import TcEnv
import RnEnv
+import RnFixity
+import RnUtils ( warnUnusedTopBinds, mkFieldEnv )
import LoadIface ( loadSrcInterface )
import TcRnMonad
import PrelNames
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 4590fc71fd..df13cedf59 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -44,6 +44,11 @@ import HsSyn
import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv
+import RnFixity
+import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
+ , warnUnusedMatches, newLocalBndrRn
+ , checkDupAndShadowedNames, checkTupSize
+ , unknownSubordinateErr )
import RnTypes
import PrelNames
import TyCon ( tyConName )
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index af145e815f..572ed82814 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -21,6 +21,11 @@ import RdrName
import RnTypes
import RnBinds
import RnEnv
+import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames
+ , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
+ , checkShadowedRdrNames, warnUnusedTypePatterns
+ , extendTyVarEnvFVRn, newLocalBndrsRn )
+import RnUnbound ( mkUnboundName )
import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcAnnotations ( annCtxt )
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 2eeecd1f5f..e0f9493291 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -18,6 +18,8 @@ import TcRnMonad
import Kind
import RnEnv
+import RnUtils ( HsDocContext(..), newLocalBndrRn )
+import RnUnbound ( isUnboundName )
import RnSource ( rnSrcDecls, findSplice )
import RnPat ( rnPat )
import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) )
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 74e6b528e5..492862bc33 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -38,6 +38,12 @@ import DynFlags
import HsSyn
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
+import RnUnbound ( perhapsForallMsg )
+import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
+ , pprHsDocContext, bindLocalNamesFV, dupNamesErr
+ , newLocalBndrRn, checkShadowedRdrNames )
+import RnFixity ( lookupFieldFixityRn, lookupFixityRn
+ , lookupTyFixityRn )
import TcRnMonad
import RdrName
import PrelNames
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
new file mode 100644
index 0000000000..cf5dab5d37
--- /dev/null
+++ b/compiler/rename/RnUnbound.hs
@@ -0,0 +1,340 @@
+{-
+
+This module contains helper functions for reporting and creating
+unbound variables.
+
+-}
+module RnUnbound ( mkUnboundName
+ , mkUnboundNameRdr
+ , isUnboundName
+ , reportUnboundName
+ , unknownNameSuggestions
+ , WhereLooking(..)
+ , unboundName
+ , unboundNameX
+ , perhapsForallMsg ) where
+
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import Module
+import SrcLoc
+import Outputable
+import PrelNames ( mkUnboundName, forall_tv_RDR, isUnboundName )
+import Util
+import Maybes
+import DynFlags
+import FastString
+import Data.List
+import Data.Function ( on )
+
+{-
+************************************************************************
+* *
+ What to do when a lookup fails
+* *
+************************************************************************
+-}
+
+data WhereLooking = WL_Any -- Any binding
+ | WL_Global -- Any top-level binding (local or imported)
+ | WL_LocalTop -- Any top-level binding in this module
+ | WL_LocalOnly
+ -- Only local bindings
+ -- (pattern synonyms declaractions,
+ -- see Note [Renaming pattern synonym variables])
+
+mkUnboundNameRdr :: RdrName -> Name
+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
+
+reportUnboundName :: RdrName -> RnM Name
+reportUnboundName rdr = unboundName WL_Any rdr
+
+unboundName :: WhereLooking -> RdrName -> RnM Name
+unboundName wl rdr = unboundNameX wl rdr Outputable.empty
+
+unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
+unboundNameX where_look rdr_name extra
+ = do { dflags <- getDynFlags
+ ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
+ what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+ err = unknownNameErr what rdr_name $$ extra
+ ; if not show_helpful_errors
+ then addErr err
+ else do { local_env <- getLocalRdrEnv
+ ; global_env <- getGlobalRdrEnv
+ ; impInfo <- getImports
+ ; let suggestions = unknownNameSuggestions_ where_look
+ dflags global_env local_env impInfo rdr_name
+ ; addErr (err $$ suggestions) }
+ ; return (mkUnboundNameRdr rdr_name) }
+
+unknownNameErr :: SDoc -> RdrName -> SDoc
+unknownNameErr what rdr_name
+ = vcat [ hang (text "Not in scope:")
+ 2 (what <+> quotes (ppr rdr_name))
+ , extra ]
+ where
+ extra | rdr_name == forall_tv_RDR = perhapsForallMsg
+ | otherwise = Outputable.empty
+
+type HowInScope = Either SrcSpan ImpDeclSpec
+ -- Left loc => locally bound at loc
+ -- Right ispec => imported as specified by ispec
+
+
+-- | Called from the typechecker (TcErrors) when we find an unbound variable
+unknownNameSuggestions :: DynFlags
+ -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+ -> RdrName -> SDoc
+unknownNameSuggestions = unknownNameSuggestions_ WL_Any
+
+unknownNameSuggestions_ :: WhereLooking -> DynFlags
+ -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+ -> RdrName -> SDoc
+unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =
+ similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
+ importSuggestions where_look imports tried_rdr_name $$
+ extensionSuggestions tried_rdr_name
+
+
+similarNameSuggestions :: WhereLooking -> DynFlags
+ -> GlobalRdrEnv -> LocalRdrEnv
+ -> RdrName -> SDoc
+similarNameSuggestions where_look dflags global_env
+ local_env tried_rdr_name
+ = case suggest of
+ [] -> Outputable.empty
+ [p] -> perhaps <+> pp_item p
+ ps -> sep [ perhaps <+> text "one of these:"
+ , nest 2 (pprWithCommas pp_item ps) ]
+ where
+ all_possibilities :: [(String, (RdrName, HowInScope))]
+ all_possibilities
+ = [ (showPpr dflags r, (r, Left loc))
+ | (r,loc) <- local_possibilities local_env ]
+ ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
+
+ suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
+ perhaps = text "Perhaps you meant"
+
+ pp_item :: (RdrName, HowInScope) -> SDoc
+ 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 (text "line" <+> int (srcSpanStartLine l))
+ pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported
+ parens (text "imported from" <+> ppr (is_mod is))
+
+ pp_ns :: RdrName -> SDoc
+ pp_ns rdr | ns /= tried_ns = pprNameSpace ns
+ | otherwise = Outputable.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 = nameSpacesRelated (occNameSpace occ) tried_ns
+ && isSymOcc occ == tried_is_sym
+ -- Treat operator and non-operators as non-matching
+ -- This heuristic avoids things like
+ -- Not in scope 'f'; perhaps you meant '+' (from Prelude)
+
+ local_ok = case where_look of { WL_Any -> True
+ ; WL_LocalOnly -> True
+ ; _ -> False }
+ local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
+ local_possibilities env
+ | tried_is_qual = []
+ | not local_ok = []
+ | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name)
+ | name <- localRdrEnvElts env
+ , let occ = nameOccName name
+ , correct_name_space occ]
+
+ gre_ok :: GlobalRdrElt -> Bool
+ gre_ok = case where_look of
+ WL_LocalTop -> isLocalGRE
+ WL_LocalOnly -> const False
+ _ -> const True
+
+ global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
+ global_possibilities global_env
+ | tried_is_qual = [ (rdr_qual, (rdr_qual, how))
+ | gre <- globalRdrEnvElts global_env
+ , gre_ok gre
+ , let name = gre_name gre
+ occ = nameOccName name
+ , correct_name_space occ
+ , (mod, how) <- quals_in_scope gre
+ , let rdr_qual = mkRdrQual mod occ ]
+
+ | otherwise = [ (rdr_unqual, pair)
+ | gre <- globalRdrEnvElts global_env
+ , gre_ok gre
+ , let name = gre_name gre
+ occ = nameOccName name
+ rdr_unqual = mkRdrUnqual occ
+ , correct_name_space occ
+ , pair <- case (unquals_in_scope gre, quals_only gre) of
+ (how:_, _) -> [ (rdr_unqual, how) ]
+ ([], pr:_) -> [ pr ] -- See Note [Only-quals]
+ ([], []) -> [] ]
+
+ -- Note [Only-quals]
+ -- The second alternative returns those names with the same
+ -- OccName as the one we tried, but live in *qualified* imports
+ -- e.g. if you have:
+ --
+ -- > import qualified Data.Map as Map
+ -- > foo :: Map
+ --
+ -- then we suggest @Map.Map@.
+
+ --------------------
+ unquals_in_scope :: GlobalRdrElt -> [HowInScope]
+ unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
+ | lcl = [ Left (nameSrcSpan n) ]
+ | otherwise = [ Right ispec
+ | i <- is, let ispec = is_decl i
+ , not (is_qual ispec) ]
+
+ --------------------
+ quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
+ -- Ones for which the qualified version is in scope
+ quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
+ | lcl = case nameModule_maybe n of
+ Nothing -> []
+ Just m -> [(moduleName m, Left (nameSrcSpan n))]
+ | otherwise = [ (is_as ispec, Right ispec)
+ | i <- is, let ispec = is_decl i ]
+
+ --------------------
+ quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]
+ -- Ones for which *only* the qualified version is in scope
+ quals_only (GRE { gre_name = n, gre_imp = is })
+ = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)
+ | i <- is, let ispec = is_decl i, is_qual ispec ]
+
+-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.
+importSuggestions :: WhereLooking -> ImportAvails -> RdrName -> SDoc
+importSuggestions where_look imports rdr_name
+ | WL_LocalOnly <- where_look = Outputable.empty
+ | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
+ | null interesting_imports
+ , Just name <- mod_name
+ = hsep
+ [ text "No module named"
+ , quotes (ppr name)
+ , text "is imported."
+ ]
+ | is_qualified
+ , null helpful_imports
+ , [(mod,_)] <- interesting_imports
+ = hsep
+ [ text "Module"
+ , quotes (ppr mod)
+ , text "does not export"
+ , quotes (ppr occ_name) <> dot
+ ]
+ | is_qualified
+ , null helpful_imports
+ , mods <- map fst interesting_imports
+ = hsep
+ [ text "Neither"
+ , quotedListWithNor (map ppr mods)
+ , text "exports"
+ , quotes (ppr occ_name) <> dot
+ ]
+ | [(mod,imv)] <- helpful_imports_non_hiding
+ = fsep
+ [ text "Perhaps you want to add"
+ , quotes (ppr occ_name)
+ , text "to the import list"
+ , text "in the import of"
+ , quotes (ppr mod)
+ , parens (ppr (imv_span imv)) <> dot
+ ]
+ | not (null helpful_imports_non_hiding)
+ = fsep
+ [ text "Perhaps you want to add"
+ , quotes (ppr occ_name)
+ , text "to one of these import lists:"
+ ]
+ $$
+ nest 2 (vcat
+ [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+ | (mod,imv) <- helpful_imports_non_hiding
+ ])
+ | [(mod,imv)] <- helpful_imports_hiding
+ = fsep
+ [ text "Perhaps you want to remove"
+ , quotes (ppr occ_name)
+ , text "from the explicit hiding list"
+ , text "in the import of"
+ , quotes (ppr mod)
+ , parens (ppr (imv_span imv)) <> dot
+ ]
+ | not (null helpful_imports_hiding)
+ = fsep
+ [ text "Perhaps you want to remove"
+ , quotes (ppr occ_name)
+ , text "from the hiding clauses"
+ , text "in one of these imports:"
+ ]
+ $$
+ nest 2 (vcat
+ [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+ | (mod,imv) <- helpful_imports_hiding
+ ])
+ | otherwise
+ = Outputable.empty
+ where
+ is_qualified = isQual rdr_name
+ (mod_name, occ_name) = case rdr_name of
+ Unqual occ_name -> (Nothing, occ_name)
+ Qual mod_name occ_name -> (Just mod_name, occ_name)
+ _ -> error "importSuggestions: dead code"
+
+
+ -- What import statements provide "Mod" at all
+ -- or, if this is an unqualified name, are not qualified imports
+ interesting_imports = [ (mod, imp)
+ | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
+ , Just imp <- return $ pick (importedByUser mod_imports)
+ ]
+
+ -- We want to keep only one for each original module; preferably one with an
+ -- explicit import list (for no particularly good reason)
+ pick :: [ImportedModsVal] -> Maybe ImportedModsVal
+ pick = listToMaybe . sortBy (compare `on` prefer) . filter select
+ where select imv = case mod_name of Just name -> imv_name imv == name
+ Nothing -> not (imv_qualified imv)
+ prefer imv = (imv_is_hiding imv, imv_span imv)
+
+ -- Which of these would export a 'foo'
+ -- (all of these are restricted imports, because if they were not, we
+ -- wouldn't have an out-of-scope error in the first place)
+ helpful_imports = filter helpful interesting_imports
+ where helpful (_,imv)
+ = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name
+
+ -- Which of these do that because of an explicit hiding list resp. an
+ -- explicit import list
+ (helpful_imports_hiding, helpful_imports_non_hiding)
+ = partition (imv_is_hiding . snd) helpful_imports
+
+extensionSuggestions :: RdrName -> SDoc
+extensionSuggestions rdrName
+ | rdrName == mkUnqual varName (fsLit "mdo") ||
+ rdrName == mkUnqual varName (fsLit "rec")
+ = text "Perhaps you meant to use RecursiveDo"
+ | otherwise = Outputable.empty
+
+perhapsForallMsg :: SDoc
+perhapsForallMsg
+ = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"
+ , text "to enable explicit-forall syntax: forall <tvs>. <type>"]
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
new file mode 100644
index 0000000000..cdeb84883b
--- /dev/null
+++ b/compiler/rename/RnUtils.hs
@@ -0,0 +1,410 @@
+{-
+
+This module contains miscellaneous functions related to renaming.
+
+-}
+module RnUtils (
+ checkDupRdrNames, checkShadowedRdrNames,
+ checkDupNames, checkDupAndShadowedNames, dupNamesErr,
+ checkTupSize,
+ addFvRn, mapFvRn, mapMaybeFvRn,
+ warnUnusedMatches, warnUnusedTypePatterns,
+ warnUnusedTopBinds, warnUnusedLocalBinds,
+ mkFieldEnv,
+ unknownSubordinateErr, badQualBndrErr,
+ HsDocContext(..), pprHsDocContext,
+ inHsDocContext, withHsDocContext,
+
+ newLocalBndrRn, newLocalBndrsRn,
+
+ bindLocalNames, bindLocalNamesFV,
+
+ addNameClashErrRn, extendTyVarEnvFVRn
+
+)
+
+where
+
+
+import HsSyn
+import RdrName
+import HscTypes
+import TcEnv
+import TcRnMonad
+import Name
+import NameSet
+import NameEnv
+import DataCon
+import SrcLoc
+import Outputable
+import Util
+import BasicTypes ( TopLevelFlag(..) )
+import ListSetOps ( removeDups )
+import DynFlags
+import FastString
+import Control.Monad
+import Data.List
+import Constants ( mAX_TUPLE_SIZE )
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+*********************************************************
+* *
+\subsection{Binding}
+* *
+*********************************************************
+-}
+
+newLocalBndrRn :: Located RdrName -> RnM Name
+-- Used for non-top-level binders. These should
+-- never be qualified.
+newLocalBndrRn (L loc rdr_name)
+ | Just name <- isExact_maybe rdr_name
+ = return name -- This happens in code generated by Template Haskell
+ -- See Note [Binders in Template Haskell] in Convert.hs
+ | otherwise
+ = do { unless (isUnqual rdr_name)
+ (addErrAt loc (badQualBndrErr rdr_name))
+ ; uniq <- newUnique
+ ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+
+newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
+newLocalBndrsRn = mapM newLocalBndrRn
+
+bindLocalNames :: [Name] -> RnM a -> RnM a
+bindLocalNames names enclosed_scope
+ = do { lcl_env <- getLclEnv
+ ; let th_level = thLevel (tcl_th_ctxt lcl_env)
+ th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
+ [ (n, (NotTopLevel, th_level)) | n <- names ]
+ rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
+ ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
+ , tcl_rdr = rdr_env' })
+ enclosed_scope }
+
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+bindLocalNamesFV names enclosed_scope
+ = do { (result, fvs) <- bindLocalNames names enclosed_scope
+ ; return (result, delFVs names fvs) }
+
+-------------------------------------
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+ -- This function is used only in rnSourceDecl on InstDecl
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
+-------------------------------------
+checkDupRdrNames :: [Located RdrName] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupRdrNames rdr_names_w_loc
+ = mapM_ (dupNamesErr getLoc) dups
+ where
+ (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
+
+checkDupNames :: [Name] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupNames names = check_dup_names (filterOut isSystemName names)
+ -- See Note [Binders in Template Haskell] in Convert
+
+check_dup_names :: [Name] -> RnM ()
+check_dup_names names
+ = mapM_ (dupNamesErr nameSrcSpan) dups
+ where
+ (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
+
+---------------------
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+ = do { envs <- getRdrEnvs
+ ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
+ where
+ filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
+ -- See Note [Binders in Template Haskell] in Convert
+ get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)
+
+checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
+checkDupAndShadowedNames envs names
+ = do { check_dup_names filtered_names
+ ; checkShadowedOccs envs get_loc_occ filtered_names }
+ where
+ filtered_names = filterOut isSystemName names
+ -- See Note [Binders in Template Haskell] in Convert
+ get_loc_occ name = (nameSrcSpan name, nameOccName name)
+
+-------------------------------------
+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
+ -> (a -> (SrcSpan, OccName))
+ -> [a] -> RnM ()
+checkShadowedOccs (global_env,local_env) get_loc_occ ns
+ = whenWOptM Opt_WarnNameShadowing $
+ do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
+ ; mapM_ check_shadow ns }
+ where
+ check_shadow n
+ | startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
+ -- See Trac #3262
+ | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
+ | otherwise = do { gres' <- filterM is_shadowed_gre gres
+ ; complain (map pprNameProvenance gres') }
+ where
+ (loc,occ) = get_loc_occ n
+ mb_local = lookupLocalRdrOcc local_env occ
+ gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
+ -- Make an Unqualified RdrName and look that up, so that
+ -- we don't find any GREs that are in scope qualified-only
+
+ complain [] = return ()
+ complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
+ loc
+ (shadowedNameWarn occ pp_locs)
+
+ is_shadowed_gre :: GlobalRdrElt -> RnM Bool
+ -- Returns False for record selectors that are shadowed, when
+ -- punning or wild-cards are on (cf Trac #2723)
+ is_shadowed_gre gre | isRecFldGRE gre
+ = do { dflags <- getDynFlags
+ ; return $ not (xopt LangExt.RecordPuns dflags
+ || xopt LangExt.RecordWildCards dflags) }
+ is_shadowed_gre _other = return True
+
+
+{-
+************************************************************************
+* *
+\subsection{Free variable manipulation}
+* *
+************************************************************************
+-}
+
+-- A useful utility
+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
+ ; return (res, fvs1 `plusFV` fvs2) }
+
+mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
+mapFvRn f xs = do stuff <- mapM f xs
+ case unzip stuff of
+ (ys, fvs_s) -> return (ys, plusFVs fvs_s)
+
+mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
+
+{-
+************************************************************************
+* *
+\subsection{Envt utility functions}
+* *
+************************************************************************
+-}
+
+warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
+warnUnusedTopBinds gres
+ = whenWOptM Opt_WarnUnusedTopBinds
+ $ do env <- getGblEnv
+ let isBoot = tcg_src env == HsBootFile
+ let noParent gre = case gre_par gre of
+ NoParent -> True
+ _ -> False
+ -- Don't warn about unused bindings with parents in
+ -- .hs-boot files, as you are sometimes required to give
+ -- unused bindings (trac #3449).
+ -- HOWEVER, in a signature file, you are never obligated to put a
+ -- definition in the main text. Thus, if you define something
+ -- and forget to export it, we really DO want to warn.
+ gres' = if isBoot then filter noParent gres
+ else gres
+ warnUnusedGREs gres'
+
+warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
+ :: [Name] -> FreeVars -> RnM ()
+warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
+warnUnusedMatches = check_unused Opt_WarnUnusedMatches
+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
+
+check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
+check_unused flag bound_names used_names
+ = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
+ bound_names))
+
+-------------------------
+-- Helpers
+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
+warnUnusedGREs gres = mapM_ warnUnusedGRE gres
+
+warnUnused :: WarningFlag -> [Name] -> RnM ()
+warnUnused flag names = do
+ fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+ mapM_ (warnUnused1 flag fld_env) names
+
+warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
+warnUnused1 flag fld_env name
+ = when (reportable name occ) $
+ addUnusedWarning flag
+ occ (nameSrcSpan name)
+ (text "Defined but not used")
+ where
+ occ = case lookupNameEnv fld_env name of
+ Just (fl, _) -> mkVarOccFS fl
+ Nothing -> nameOccName name
+
+warnUnusedGRE :: GlobalRdrElt -> RnM ()
+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
+ | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+ warnUnused1 Opt_WarnUnusedTopBinds fld_env name
+ | otherwise = when (reportable name occ) (mapM_ warn is)
+ where
+ occ = greOccName gre
+ warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
+ where
+ span = importSpecLoc spec
+ pp_mod = quotes (ppr (importSpecModule spec))
+ msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
+
+-- | Make a map from selector names to field labels and parent tycon
+-- names, to be used when reporting unused record fields.
+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
+ | gres <- occEnvElts rdr_env
+ , gre <- gres
+ , Just lbl <- [greLabel gre]
+ ]
+
+-- | Should we report the fact that this 'Name' is unused? The
+-- 'OccName' may differ from 'nameOccName' due to
+-- DuplicateRecordFields.
+reportable :: Name -> OccName -> Bool
+reportable name occ
+ | isWiredInName name = False -- Don't report unused wired-in names
+ -- Otherwise we get a zillion warnings
+ -- from Data.Tuple
+ | otherwise = not (startsWithUnderscore occ)
+
+addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning flag occ span msg
+ = addWarnAt (Reason flag) span $
+ sep [msg <> colon,
+ nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+ <+> quotes (ppr occ)]
+
+addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
+addNameClashErrRn rdr_name gres
+ | all isLocalGRE gres && not (all isRecFldGRE gres)
+ -- If there are two or more *local* defns, we'll have reported
+ = return () -- that already, and we don't want an error cascade
+ | otherwise
+ = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
+ text "It could refer to" <+> vcat (msg1 : msgs)])
+ where
+ (np1:nps) = gres
+ msg1 = ptext (sLit "either") <+> mk_ref np1
+ msgs = [text " or" <+> mk_ref np | np <- nps]
+ mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
+ where nom = case gre_par gre of
+ FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
+ _ -> quotes (ppr (gre_name gre))
+
+shadowedNameWarn :: OccName -> [SDoc] -> SDoc
+shadowedNameWarn occ shadowed_locs
+ = sep [text "This binding for" <+> quotes (ppr occ)
+ <+> text "shadows the existing binding" <> plural shadowed_locs,
+ nest 2 (vcat shadowed_locs)]
+
+
+unknownSubordinateErr :: SDoc -> RdrName -> SDoc
+unknownSubordinateErr doc op -- Doc is "method of class" or
+ -- "field of constructor"
+ = quotes (ppr op) <+> text "is not a (visible)" <+> doc
+
+
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
+dupNamesErr get_loc names
+ = addErrAt big_loc $
+ vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
+ locations]
+ where
+ locs = map get_loc names
+ big_loc = foldr1 combineSrcSpans locs
+ locations = text "Bound at:" <+> vcat (map ppr (sort locs))
+
+badQualBndrErr :: RdrName -> SDoc
+badQualBndrErr rdr_name
+ = text "Qualified name in binding position:" <+> ppr rdr_name
+
+
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+ | tup_size <= mAX_TUPLE_SIZE
+ = return ()
+ | otherwise
+ = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
+ nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
+ nest 2 (text "Workaround: use nested tuples or define a data type")])
+
+{-
+************************************************************************
+* *
+\subsection{Contexts for renaming errors}
+* *
+************************************************************************
+-}
+
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+-- Merge TcType.UserTypeContext in to it.
+data HsDocContext
+ = TypeSigCtx SDoc
+ | PatCtx
+ | SpecInstSigCtx
+ | DefaultDeclCtx
+ | ForeignDeclCtx (Located RdrName)
+ | DerivDeclCtx
+ | RuleCtx FastString
+ | TyDataCtx (Located RdrName)
+ | TySynCtx (Located RdrName)
+ | TyFamilyCtx (Located RdrName)
+ | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance
+ | ConDeclCtx [Located Name]
+ | ClassDeclCtx (Located RdrName)
+ | ExprWithTySigCtx
+ | TypBrCtx
+ | HsTypeCtx
+ | GHCiCtx
+ | SpliceTypeCtx (LHsType RdrName)
+ | ClassInstanceCtx
+ | VectDeclCtx (Located RdrName)
+ | GenericCtx SDoc -- Maybe we want to use this more!
+
+withHsDocContext :: HsDocContext -> SDoc -> SDoc
+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
+
+inHsDocContext :: HsDocContext -> SDoc
+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
+
+pprHsDocContext :: HsDocContext -> SDoc
+pprHsDocContext (GenericCtx doc) = doc
+pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc
+pprHsDocContext PatCtx = text "a pattern type-signature"
+pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
+pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
+pprHsDocContext DerivDeclCtx = text "a deriving declaration"
+pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name
+pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
+pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
+pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
+pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name)
+pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name)
+pprHsDocContext ExprWithTySigCtx = text "an expression type signature"
+pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type"
+pprHsDocContext HsTypeCtx = text "a type argument"
+pprHsDocContext GHCiCtx = text "GHCi input"
+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
+pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances"
+
+pprHsDocContext (ForeignDeclCtx name)
+ = text "the foreign declaration for" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx [name])
+ = text "the definition of data constructor" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx names)
+ = text "the definition of data constructors" <+> interpp'SP names
+pprHsDocContext (VectDeclCtx tycon)
+ = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index 2cc742412a..a132f99119 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -45,7 +45,7 @@ import HscTypes
import Outputable
import Type
import FastString
-import RnEnv
+import RnFixity ( lookupFixityRn )
import Maybes
import TcEnv
import Var
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 86f04095b9..8076115b6c 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -32,6 +32,7 @@ import TcMType
import RnNames( extendGlobalRdrEnvRn )
import RnBinds
import RnEnv
+import RnUtils ( bindLocalNamesFV )
import RnSource ( addTcgDUs )
import Avail
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index ec33bc096b..adbf3b2d51 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -14,7 +14,7 @@ import TcRnMonad
import TcMType
import TcUnify( occCheckForErrors, OccCheckResult(..) )
import TcType
-import RnEnv( unknownNameSuggestions )
+import RnUnbound ( unknownNameSuggestions )
import Type
import TyCoRep
import Kind
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 48252dffc6..e521b735a4 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -32,8 +32,8 @@ import TcSigs ( tcUserTypeSig, tcInstSig )
import TcSimplify ( simplifyInfer, InferMode(..) )
import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInstEnv ( FamInstEnvs )
-import RnEnv ( addUsedGRE, addNameClashErrRn
- , unknownSubordinateErr )
+import RnEnv ( addUsedGRE )
+import RnUtils ( addNameClashErrRn, unknownSubordinateErr )
import TcEnv
import TcArrows
import TcMatches
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 45df4acd13..b9ffd6a835 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -49,6 +49,8 @@ import Inst( deeplyInstantiate )
import TcUnify( checkConstraints )
import RnTypes
import RnExpr
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn )
import MkId
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index b3d9317768..2da1862f98 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -12,6 +12,8 @@ import TcMType
import TcType
import RnNames
import RnEnv
+import RnUnbound ( reportUnboundName, mkUnboundNameRdr )
+import RnUtils ( addNameClashErrRn )
import ErrUtils
import Id
import IdInfo
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index e4a034b5f9..67bc8f7a30 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -128,7 +128,11 @@ module TcRnTypes(
-- Misc other types
TcId, TcIdSet,
Hole(..), holeOcc,
- NameShape(..)
+ NameShape(..),
+
+ -- Role annotations
+ RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
+ lookupRoleAnnot, getRoleAnnots,
) where
@@ -176,6 +180,7 @@ import FastString
import qualified GHC.LanguageExtensions as LangExt
import Fingerprint
import Util
+import PrelNames ( isUnboundName )
import Control.Monad (ap, liftM, msum)
#if __GLASGOW_HASKELL__ > 710
@@ -187,6 +192,7 @@ import qualified Data.Set as S
import Data.Map ( Map )
import Data.Dynamic ( Dynamic )
import Data.Typeable ( TypeRep )
+import Data.Maybe ( mapMaybe )
import GHCi.Message
import GHCi.RemoteTypes
@@ -3422,3 +3428,31 @@ data TcPluginResult
-- and the evidence for them is recorded.
-- The second field contains new work, that should be processed by
-- the constraint solver.
+
+{- *********************************************************************
+* *
+ Role annotations
+* *
+********************************************************************* -}
+
+type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name)
+
+mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv
+mkRoleAnnotEnv role_annot_decls
+ = mkNameEnv [ (name, ra_decl)
+ | ra_decl <- role_annot_decls
+ , let name = roleAnnotDeclName (unLoc ra_decl)
+ , not (isUnboundName name) ]
+ -- Some of the role annots will be unbound;
+ -- we don't wish to include these
+
+emptyRoleAnnotEnv :: RoleAnnotEnv
+emptyRoleAnnotEnv = emptyNameEnv
+
+lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name)
+lookupRoleAnnot = lookupNameEnv
+
+getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv)
+getRoleAnnots bndrs role_env
+ = ( mapMaybe (lookupRoleAnnot role_env) bndrs
+ , delListFromNameEnv role_env bndrs )
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index be998e3d78..007f825d48 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -57,6 +57,8 @@ import HscTypes
import Convert
import RnExpr
import RnEnv
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn_help )
import RnTypes
import TcHsSyn
import TcSimplify
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 2a2b55354a..e0929f494c 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -37,8 +37,7 @@ import TcHsType
import TcMType
import TysWiredIn ( unitTy )
import TcType
-import RnEnv( RoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot
- , lookupConstructorFields )
+import RnEnv( lookupConstructorFields )
import FamInst
import FamInstEnv
import Coercion
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 1b81ec7cb0..d147cac65c 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -29,7 +29,6 @@ module TcTyDecls(
import TcRnMonad
import TcEnv
import TcBinds( tcRecSelBinds )
-import RnEnv( RoleAnnotEnv, lookupRoleAnnot )
import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )
import TcType
import TysWiredIn( unitTy )
View Lorry Controller Status