module GHC.Rename.Unbound
( mkUnboundName
, mkUnboundNameRdr
, isUnboundName
, reportUnboundName
, reportUnboundName'
, unknownNameSuggestions
, WhatLooking(..)
, WhereLooking(..)
, LookingFor(..)
, unboundName
, unboundNameX
, notInScopeErr
, nameSpacesRelated
)
where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Hint
( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames)
, LanguageExtensionHint (SuggestSingleExtension)
, ImportSuggestion(..), SimilarName(..), HowInScope(..) )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Unique.DFM (udfmToList)
import GHC.Unit.Module
import GHC.Unit.Module.Imported
import GHC.Unit.Home.ModInfo
import GHC.Data.Bag
import GHC.Utils.Outputable (empty)
import Data.List (sortBy, partition, nub)
import Data.List.NonEmpty ( pattern (:|), NonEmpty )
import Data.Function ( on )
data WhatLooking = WL_Anything
| WL_Constructor
| WL_RecField
| WL_None
deriving Eq
data WhereLooking = WL_Anywhere
| WL_Global
| WL_LocalTop
| WL_LocalOnly
data LookingFor = LF { lf_which :: WhatLooking
, lf_where :: WhereLooking
}
mkUnboundNameRdr :: RdrName -> Name
mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
reportUnboundName' :: WhatLooking -> RdrName -> RnM Name
reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr
reportUnboundName :: RdrName -> RnM Name
reportUnboundName = reportUnboundName' WL_Anything
unboundName :: LookingFor -> RdrName -> RnM Name
unboundName lf rdr = unboundNameX lf rdr []
unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name
unboundNameX looking_for rdr_name hints
= do { dflags <- getDynFlags
; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
err = notInScopeErr (lf_where looking_for) rdr_name
; if not show_helpful_errors
then addErr $ TcRnNotInScope err rdr_name [] hints
else do { local_env <- getLocalRdrEnv
; global_env <- getGlobalRdrEnv
; impInfo <- getImports
; currmod <- getModule
; hpt <- getHpt
; let (imp_errs, suggs) =
unknownNameSuggestions_ looking_for
dflags hpt currmod global_env local_env impInfo
rdr_name
; addErr $
TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) }
; return (mkUnboundNameRdr rdr_name) }
notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError
notInScopeErr where_look rdr_name
| Just name <- isExact_maybe rdr_name
= NoExactName name
| WL_LocalTop <- where_look
= NoTopLevelBinding
| otherwise
= NotInScope
unknownNameSuggestions :: WhatLooking -> DynFlags
-> HomePackageTable -> Module
-> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-> RdrName -> ([ImportError], [GhcHint])
unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere)
unknownNameSuggestions_ :: LookingFor -> DynFlags
-> HomePackageTable -> Module
-> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-> RdrName -> ([ImportError], [GhcHint])
unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env
imports tried_rdr_name = (imp_errs, suggs)
where
suggs = mconcat
[ if_ne (SuggestSimilarNames tried_rdr_name) $
similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name
, map ImportSuggestion imp_suggs
, extensionSuggestions tried_rdr_name
, fieldSelectorSuggestions global_env tried_rdr_name ]
(imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name
if_ne :: (NonEmpty a -> b) -> [a] -> [b]
if_ne _ [] = []
if_ne f (a : as) = [f (a :| as)]
fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint]
fieldSelectorSuggestions global_env tried_rdr_name
| null gres = []
| otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents]
where
gres = filter isNoFieldSelectorGRE $
lookupGRE_RdrName' tried_rdr_name global_env
parents = [ parent | ParentIs parent <- map gre_par gres ]
similarNameSuggestions :: LookingFor -> DynFlags
-> GlobalRdrEnv -> LocalRdrEnv
-> RdrName -> [SimilarName]
similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
local_env tried_rdr_name
= fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
where
all_possibilities :: [(String, SimilarName)]
all_possibilities = case what_look of
WL_None -> []
_ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc))
| (r,loc) <- local_possibilities local_env ]
++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
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 dflags what_look tried_ns (occNameSpace occ))
&& isSymOcc occ == tried_is_sym
local_ok = case where_look of { WL_Anywhere -> 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]
global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]
global_possibilities global_env
| tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how)
| gre <- globalRdrEnvElts global_env
, isGreOk looking_for gre
, let occ = greOccName gre
, correct_name_space occ
, (mod, how) <- qualsInScope gre
, let rdr_qual = mkRdrQual mod occ ]
| otherwise = [ (rdr_unqual, sim)
| gre <- globalRdrEnvElts global_env
, isGreOk looking_for gre
, let occ = greOccName gre
rdr_unqual = mkRdrUnqual occ
, correct_name_space occ
, sim <- case (unquals_in_scope gre, quals_only gre) of
(how:_, _) -> [ SimilarRdrName rdr_unqual how ]
([], pr:_) -> [ pr ]
([], []) -> [] ]
unquals_in_scope :: GlobalRdrElt -> [HowInScope]
unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is })
| lcl = [ LocallyBoundAt (greDefinitionSrcSpan gre) ]
| otherwise = [ ImportedBy ispec
| i <- bagToList is, let ispec = is_decl i
, not (is_qual ispec) ]
quals_only :: GlobalRdrElt -> [SimilarName]
quals_only (gre@GRE { gre_imp = is })
= [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec))
| i <- bagToList is, let ispec = is_decl i, is_qual ispec ]
importSuggestions :: LookingFor
-> GlobalRdrEnv
-> HomePackageTable -> Module
-> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])
importSuggestions looking_for global_env hpt currMod imports rdr_name
| WL_LocalOnly <- lf_where looking_for = ([], [])
| WL_LocalTop <- lf_where looking_for = ([], [])
| not (isQual rdr_name || isUnqual rdr_name) = ([], [])
| null interesting_imports
, Just name <- mod_name
, show_not_imported_line name
= ([MissingModule name], [])
| is_qualified
, null helpful_imports
, (mod : mods) <- map fst interesting_imports
= ([ModulesDoNotExport (mod :| mods) occ_name], [])
| mod : mods <- helpful_imports_non_hiding
= ([], [CouldImportFrom (mod :| mods) occ_name])
| mod : mods <- helpful_imports_hiding
= ([], [CouldUnhideFrom (mod :| mods) occ_name])
| otherwise
= ([], [])
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"
interesting_imports = [ (mod, imp)
| (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
, Just imp <- return $ pick (importedByUser mod_imports)
]
pick :: [ImportedModsVal] -> Maybe ImportedModsVal
pick = listToMaybe . sortBy cmp . filter select
where select imv = case mod_name of Just name -> imv_name imv == name
Nothing -> not (imv_qualified imv)
cmp a b =
(compare `on` imv_is_hiding) a b
`thenCmp`
(SrcLoc.leftmost_smallest `on` imv_span) a b
helpful_imports = filter helpful interesting_imports
where helpful (_,imv)
= any (isGreOk looking_for) $
lookupGlobalRdrEnv (imv_all_exports imv) occ_name
(helpful_imports_hiding, helpful_imports_non_hiding)
= partition (imv_is_hiding . snd) helpful_imports
show_not_imported_line :: ModuleName -> Bool
show_not_imported_line modnam
| modnam `elem` glob_mods = False
| moduleName currMod == modnam = False
| is_last_loaded_mod modnam hpt_uniques = False
| otherwise = True
where
hpt_uniques = map fst (udfmToList hpt)
is_last_loaded_mod _ [] = False
is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam
glob_mods = nub [ mod
| gre <- globalRdrEnvElts global_env
, (mod, _) <- qualsInScope gre
]
extensionSuggestions :: RdrName -> [GhcHint]
extensionSuggestions rdrName
| rdrName == mkUnqual varName (fsLit "mdo") ||
rdrName == mkUnqual varName (fsLit "rec")
= [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo]
| otherwise
= []
qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is }
| lcl = case greDefinitionModule gre of
Nothing -> []
Just m -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))]
| otherwise = [ (is_as ispec, ImportedBy ispec)
| i <- bagToList is, let ispec = is_decl i ]
isGreOk :: LookingFor -> GlobalRdrElt -> Bool
isGreOk (LF what_look where_look) gre = what_ok && where_ok
where
what_ok = case what_look of
WL_RecField -> isRecFldGRE gre
_ -> not (isNoFieldSelectorGRE gre)
where_ok = case where_look of
WL_LocalTop -> isLocalGRE gre
WL_LocalOnly -> False
_ -> True
nameSpacesRelated :: DynFlags
-> WhatLooking
-> NameSpace
-> NameSpace
-> Bool
nameSpacesRelated dflags what_looking ns ns'
= ns' `elem` ns : [ other_ns
| (orig_ns, others) <- other_namespaces
, ns == orig_ns
, (other_ns, wls) <- others
, what_looking `elem` WL_Anything : wls
]
where
other_namespaces =
[ (varName , [(dataName, [WL_Constructor])])
, (dataName , [(varName , [WL_RecField])])
, (tvName , (tcClsName, [WL_Constructor]) : promoted_datacons)
, (tcClsName, (tvName , []) : promoted_datacons)
]
data_kinds = xopt LangExt.DataKinds dflags
promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds]