Commit ae41a50f authored by Joachim Breitner's avatar Joachim Breitner

Report all possible results from related name spaces

instead of just one matching directly. This is an alternative way to fix
ticket #9177.
parent 009e86f5
...@@ -32,6 +32,8 @@ ...@@ -32,6 +32,8 @@
module OccName ( module OccName (
-- * The 'NameSpace' type -- * The 'NameSpace' type
NameSpace, -- Abstract NameSpace, -- Abstract
nameSpacesRelated,
-- ** Construction -- ** Construction
-- $real_vs_source_data_constructors -- $real_vs_source_data_constructors
...@@ -83,8 +85,6 @@ module OccName ( ...@@ -83,8 +85,6 @@ module OccName (
isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,
toRelatedNameSpace,
-- * The 'OccEnv' type -- * The 'OccEnv' type
OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
...@@ -372,21 +372,10 @@ demoteOccName (OccName space name) = do ...@@ -372,21 +372,10 @@ demoteOccName (OccName space name) = do
space' <- demoteNameSpace space space' <- demoteNameSpace space
return $ OccName space' name return $ OccName space' name
-- What would this name be if used in the related name space -- Name spaces are related if there is a chance to mean the one when one writes
-- (variables <-> data construtors, type variables <-> type constructors) -- the other, i.e. variables <-> data construtors and type variables <-> type constructors
toRelatedNameSpace :: OccName -> Maybe OccName nameSpacesRelated :: NameSpace -> NameSpace -> Bool
toRelatedNameSpace (OccName space name) = OccName (otherNameSpace space) `fmap` name' nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2
where
name' | name == fsLit "[]" = Nothing -- Some special cases first
| name == fsLit "->" = Nothing
| hd == '(' = Nothing
| hd == ':' = Just tl
| startsVarSym hd = Just (':' `consFS` name)
| isUpper hd = Just (toLower hd `consFS` tl)
| isLower hd = Just (toUpper hd `consFS` tl)
| otherwise = pprTrace "toRelatedNameSpace" (ppr name)
Nothing
(hd,tl) = (headFS name, tailFS name)
otherNameSpace :: NameSpace -> NameSpace otherNameSpace :: NameSpace -> NameSpace
otherNameSpace VarName = DataName otherNameSpace VarName = DataName
...@@ -395,6 +384,7 @@ otherNameSpace TvName = TcClsName ...@@ -395,6 +384,7 @@ otherNameSpace TvName = TcClsName
otherNameSpace TcClsName = TvName otherNameSpace TcClsName = TvName
{- | Other names in the compiler add aditional information to an OccName. {- | Other names in the compiler add aditional information to an OccName.
This class provides a consistent way to access the underlying OccName. -} This class provides a consistent way to access the underlying OccName. -}
class HasOccName name where class HasOccName name where
......
...@@ -1452,7 +1452,7 @@ unknownNameSuggestErr where_look tried_rdr_name ...@@ -1452,7 +1452,7 @@ unknownNameSuggestErr where_look tried_rdr_name
all_possibilities all_possibilities
= [ (showPpr dflags r, (r, Left loc)) = [ (showPpr dflags r, (r, Left loc))
| (r,loc) <- local_possibilities local_env ] | (r,loc) <- local_possibilities local_env ]
++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ] ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
perhaps = ptext (sLit "Perhaps you meant") perhaps = ptext (sLit "Perhaps you meant")
...@@ -1464,21 +1464,25 @@ unknownNameSuggestErr where_look tried_rdr_name ...@@ -1464,21 +1464,25 @@ unknownNameSuggestErr where_look tried_rdr_name
; return extra_err } ; return extra_err }
where where
pp_item :: (RdrName, HowInScope) -> SDoc pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> loc' -- Locally defined pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined
where loc' = case loc of where loc' = case loc of
UnhelpfulSpan l -> parens (ppr l) UnhelpfulSpan l -> parens (ppr l)
RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l)) RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l))
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is)) parens (ptext (sLit "imported from") <+> ppr (is_mod is))
pp_ns :: RdrName -> SDoc
pp_ns rdr | ns /= tried_ns = pprNameSpace ns
| otherwise = empty
where ns = rdrNameSpace rdr
tried_occ = rdrNameOcc tried_rdr_name tried_occ = rdrNameOcc tried_rdr_name
tried_is_sym = isSymOcc tried_occ tried_is_sym = isSymOcc tried_occ
tried_ns = occNameSpace tried_occ tried_ns = occNameSpace tried_occ
tried_is_qual = isQual tried_rdr_name tried_is_qual = isQual tried_rdr_name
correct_name_space occ = occNameSpace occ == tried_ns correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns
&& isSymOcc occ == tried_is_sym && isSymOcc occ == tried_is_sym
|| toRelatedNameSpace occ == Just tried_occ
-- Treat operator and non-operators as non-matching -- Treat operator and non-operators as non-matching
-- This heuristic avoids things like -- This heuristic avoids things like
-- Not in scope 'f'; perhaps you meant '+' (from Prelude) -- Not in scope 'f'; perhaps you meant '+' (from Prelude)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment