Split up RnEnv into 4 modules, RnUnbound, RnUtils and RnFixity
authorMatthew Pickering <matthewtpickering@gmail.com>
Sat, 8 Apr 2017 15:42:32 +0000 (16:42 +0100)
committerMatthew Pickering <matthewtpickering@gmail.com>
Wed, 12 Apr 2017 18:56:25 +0000 (19:56 +0100)
Summary:
RnEnv contains functions which convertn RdrNames into Names.

RnUnbound contains helper functions for reporting and creating
unbound variables.

RnFixity contains code which maintains the fixity environent
whilst renaming.

RnUtils contains the other stuff in RnEnv.

Reviewers: austin, goldfire, bgamari

Subscribers: goldfire, rwbarton, thomie, snowleopard

Differential Revision: https://phabricator.haskell.org/D3436

22 files changed:
compiler/ghc.cabal.in
compiler/rename/RnBinds.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnFixity.hs [new file with mode: 0644]
compiler/rename/RnNames.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/rename/RnUnbound.hs [new file with mode: 0644]
compiler/rename/RnUtils.hs [new file with mode: 0644]
compiler/typecheck/TcBackpack.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnExports.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs

index 6054d85..1c9c6c6 100644 (file)
@@ -388,6 +388,9 @@ Library
         RnSource
         RnSplice
         RnTypes
+        RnFixity
+        RnUtils
+        RnUnbound
         CoreMonad
         CSE
         FloatIn
index 21d6095..9abeee2 100644 (file)
@@ -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
index a324ce4..3aa9472 100644 (file)
@@ -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.(,)
index 4e9192c..987b0be 100644 (file)
@@ -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 (file)
index 0000000..61566f0
--- /dev/null
@@ -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)
index eccd728..fa5f24f 100644 (file)
@@ -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
index 4590fc7..df13ced 100644 (file)
@@ -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 )
index af145e8..572ed82 100644 (file)
@@ -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 )
index 2eeecd1..e0f9493 100644 (file)
@@ -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(..) )
index 74e6b52..492862b 100644 (file)
@@ -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 (file)
index 0000000..cf5dab5
--- /dev/null
@@ -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 (file)
index 0000000..cdeb848
--- /dev/null
@@ -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)
index 2cc7424..a132f99 100644 (file)
@@ -45,7 +45,7 @@ import HscTypes
 import Outputable
 import Type
 import FastString
-import RnEnv
+import RnFixity ( lookupFixityRn )
 import Maybes
 import TcEnv
 import Var
index 86f0409..8076115 100644 (file)
@@ -32,6 +32,7 @@ import TcMType
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
 import RnEnv
+import RnUtils    ( bindLocalNamesFV )
 import RnSource   ( addTcgDUs )
 import Avail
 
index ec33bc0..adbf3b2 100644 (file)
@@ -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
index 48252df..e521b73 100644 (file)
@@ -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
index 45df4ac..b9ffd6a 100644 (file)
@@ -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 )
index b3d9317..2da1862 100644 (file)
@@ -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
index e4a034b..67bc8f7 100644 (file)
@@ -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 )
index be998e3..007f825 100644 (file)
@@ -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
index 2a2b553..e0929f4 100644 (file)
@@ -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
index 1b81ec7..d147cac 100644 (file)
@@ -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 )