path: root/compiler/GHC/Rename/Utils.hs

{-

This module contains miscellaneous functions related to renaming.

-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}

module GHC.Rename.Utils (
        checkDupRdrNames, checkShadowedRdrNames,
        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
        checkTupSize,
        addFvRn, mapFvRn, mapMaybeFvRn,
        warnUnusedMatches, warnUnusedTypePatterns,
        warnUnusedTopBinds, warnUnusedLocalBinds,
        checkUnusedRecordWildcard,
        mkFieldEnv,
        unknownSubordinateErr, badQualBndrErr, typeAppErr,
        HsDocContext(..), pprHsDocContext,
        inHsDocContext, withHsDocContext,

        newLocalBndrRn, newLocalBndrsRn,

        bindLocalNames, bindLocalNamesFV,

        addNameClashErrRn, extendTyVarEnvFVRn

)

where


import GhcPrelude

import GHC.Hs
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 Data.List.NonEmpty as NE
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)
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 #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 #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'


-- | Checks to see if we need to warn for -Wunused-record-wildcards or
-- -Wredundant-record-wildcards
checkUnusedRecordWildcard :: SrcSpan
                          -> FreeVars
                          -> Maybe [Name]
                          -> RnM ()
checkUnusedRecordWildcard _ _ Nothing    = return ()
checkUnusedRecordWildcard loc _ (Just [])  = do
  -- Add a new warning if the .. pattern binds no variables
  setSrcSpan loc $ warnRedundantRecordWildcard
checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs


-- | Produce a warning when the `..` pattern binds no new
-- variables.
--
-- @
--   data P = P { x :: Int }
--
--   foo (P{x, ..}) = x
-- @
--
-- The `..` here doesn't bind any variables as `x` is already bound.
warnRedundantRecordWildcard :: RnM ()
warnRedundantRecordWildcard =
  whenWOptM Opt_WarnRedundantRecordWildcards
            (addWarn (Reason Opt_WarnRedundantRecordWildcards)
                     redundantWildcardWarning)


-- | Produce a warning when no variables bound by a `..` pattern are used.
--
-- @
--   data P = P { x :: Int }
--
--   foo (P{..}) = ()
-- @
--
-- The `..` pattern binds `x` but it is not used in the RHS so we issue
-- a warning.
warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
warnUnusedRecordWildcard ns used_names = do
  let used = filter (`elemNameSet` used_names) ns
  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)
    unusedRecordWildcardWarning



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" ++ opt_str)
  where
    occ = case lookupNameEnv fld_env name of
              Just (fl, _) -> mkVarOccFS fl
              Nothing      -> nameOccName name
    opt_str = case flag of
                Opt_WarnUnusedTypePatterns -> " on the right hand side"
                _ -> ""

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)]

unusedRecordWildcardWarning :: SDoc
unusedRecordWildcardWarning =
  wildcardDoc $ text "No variables bound in the record wildcard match are used"

redundantWildcardWarning :: SDoc
redundantWildcardWarning =
  wildcardDoc $ text "Record wildcard does not bind any new variables"

wildcardDoc :: SDoc -> SDoc
wildcardDoc herald =
  herald
    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
                                            <+> quotes (text ".."))

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"
                 , nest 3 (vcat (msg1 : msgs)) ])
  where
    (np1:nps) = gres
    msg1 =  text "either" <+> ppr_gre np1
    msgs = [text "    or" <+> ppr_gre np | np <- nps]
    ppr_gre gre = sep [ pp_gre_name gre <> comma
                      , pprNameProvenance gre]

    -- When printing the name, take care to qualify it in the same
    -- way as the provenance reported by pprNameProvenance, namely
    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
    --   Ambiguous occurrence ‘null’
    --   It could refer to either ‘T15487a.null’,
    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
    --                     or ...
    -- See #15487
    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
                         , gre_lcl = lcl, gre_imp = iss })
      | FldParent { par_lbl = Just lbl } <- parent
      = text "the field" <+> quotes (ppr lbl)
      | otherwise
      = quotes (pp_qual <> dot <> ppr (nameOccName name))
      where
        pp_qual | lcl
                = ppr (nameModule name)
                | imp : _ <- iss  -- This 'imp' is the one that
                                  -- pprNameProvenance chooses
                , ImpDeclSpec { is_as = mod } <- is_decl imp
                = ppr mod
                | otherwise
                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
                  -- Invariant: either 'lcl' is True or 'iss' is non-empty

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) -> NE.NonEmpty n -> RnM ()
dupNamesErr get_loc names
  = addErrAt big_loc $
    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
          locations]
  where
    locs      = map get_loc (NE.toList 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

typeAppErr :: String -> LHsType GhcPs -> SDoc
typeAppErr what (L _ k)
  = hang (text "Illegal visible" <+> text what <+> text "application"
            <+> quotes (char '@' <> ppr k))
       2 (text "Perhaps you intended to use TypeApplications")

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
  | StandaloneKindSigCtx 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 GhcPs)
  | ClassInstanceCtx
  | 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 (StandaloneKindSigCtx doc) = text "the standalone kind 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