Commit 3e0af469 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Give lookupGRE_Name a better API

lookupGRE_Name should return either zero or one GREs, never
several. This is a consequence of INVARIANT 1 on GlobalRdrEnv.

So it's better if it returns a Maybe; the panic on multiple results
is put in one place, instead of being scattered or ignored.

Just refactoring, no change in behaviour
parent 210a2e12
...@@ -734,10 +734,14 @@ lookupGRE_RdrName rdr_name env ...@@ -734,10 +734,14 @@ lookupGRE_RdrName rdr_name env
Nothing -> [] Nothing -> []
Just gres -> pickGREs rdr_name gres Just gres -> pickGREs rdr_name gres
lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name env name lookupGRE_Name env name
= [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), = case [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name)
gre_name gre == name ] , gre_name gre == name ] of
[] -> Nothing
[gre] -> Just gre
gres -> pprPanic "lookupGRE_Name" (ppr name $$ ppr gres)
-- See INVARIANT 1 on GlobalRdrEnv
lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt] lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt]
-- Used when looking up record fields, where the selector name and -- Used when looking up record fields, where the selector name and
...@@ -751,8 +755,10 @@ getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] ...@@ -751,8 +755,10 @@ getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
-- Returns all the qualifiers by which 'x' is in scope -- Returns all the qualifiers by which 'x' is in scope
-- Nothing means "the unqualified version is in scope" -- Nothing means "the unqualified version is in scope"
-- [] means the thing is not in scope at all -- [] means the thing is not in scope at all
getGRE_NameQualifier_maybes env getGRE_NameQualifier_maybes env name
= map (qualifier_maybe) . lookupGRE_Name env = case lookupGRE_Name env name of
Just gre -> [qualifier_maybe gre]
Nothing -> []
where where
qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss })
| lcl = Nothing | lcl = Nothing
......
...@@ -793,8 +793,7 @@ getInfo allInfo name ...@@ -793,8 +793,7 @@ getInfo allInfo name
-- The one we looked for in the first place! -- The one we looked for in the first place!
| pretendNameIsInScope n = True | pretendNameIsInScope n = True
| isBuiltInSyntax n = True | isBuiltInSyntax n = True
| isExternalName n = any ((== n) . gre_name) | isExternalName n = isJust (lookupGRE_Name rdr_env n)
(lookupGRE_Name rdr_env n)
| otherwise = True | otherwise = True
-- | Returns all names in scope in the current interactive context -- | Returns all names in scope in the current interactive context
......
...@@ -1018,7 +1018,7 @@ addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () ...@@ -1018,7 +1018,7 @@ addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
addUsedDataCons rdr_env tycon addUsedDataCons rdr_env tycon
= addUsedGREs [ gre = addUsedGREs [ gre
| dc <- tyConDataCons tycon | dc <- tyConDataCons tycon
, gre : _ <- [lookupGRE_Name rdr_env (dataConName dc) ] ] , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
addUsedGRE :: Bool -> GlobalRdrElt -> RnM () addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()
-- Called for both local and imported things -- Called for both local and imported things
......
...@@ -1973,8 +1973,8 @@ exportClashErr global_env name1 name2 ie1 ie2 ...@@ -1973,8 +1973,8 @@ exportClashErr global_env name1 name2 ie1 ie2
-- get_gre finds a GRE for the Name, so that we can show its provenance -- get_gre finds a GRE for the Name, so that we can show its provenance
get_gre name get_gre name
= case lookupGRE_Name global_env name of = case lookupGRE_Name global_env name of
(gre:_) -> gre Just gre -> gre
[] -> pprPanic "exportClashErr" (ppr name) Nothing -> pprPanic "exportClashErr" (ppr name)
get_loc name = greSrcSpan (get_gre name) get_loc name = greSrcSpan (get_gre name)
(name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
then (name1, ie1, name2, ie2) then (name1, ie1, name2, ie2)
......
...@@ -637,12 +637,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ...@@ -637,12 +637,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- (that is, the parent of the data constructor), -- (that is, the parent of the data constructor),
-- or 'Nothing' if it is a pattern synonym or not in scope. -- or 'Nothing' if it is a pattern synonym or not in scope.
-- That's the parent to use for looking up record fields. -- That's the parent to use for looking up record fields.
find_tycon env con find_tycon env con_name
| Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
= Just (tyConName (dataConTyCon dc)) = Just (tyConName (dataConTyCon dc))
-- Special case for [], which is built-in syntax -- Special case for [], which is built-in syntax
-- and not in the GlobalRdrEnv (Trac #8448) -- and not in the GlobalRdrEnv (Trac #8448)
| [gre] <- lookupGRE_Name env con
| Just gre <- lookupGRE_Name env con_name
= case gre_par gre of = case gre_par gre of
ParentIs p -> Just p ParentIs p -> Just p
_ -> Nothing _ -> Nothing
......
...@@ -1358,11 +1358,11 @@ toParents rdr_env ns ...@@ -1358,11 +1358,11 @@ toParents rdr_env ns
getParent :: GlobalRdrEnv -> Name -> Name getParent :: GlobalRdrEnv -> Name -> Name
getParent rdr_env n getParent rdr_env n
= case lookupGRE_Name rdr_env n of = case lookupGRE_Name rdr_env n of
gre : _ -> case gre_par gre of Just gre -> case gre_par gre of
ParentIs { par_is = p } -> p ParentIs { par_is = p } -> p
FldParent { par_is = p } -> p FldParent { par_is = p } -> p
_ -> n _ -> n
_ -> n Nothing -> n
{- Note [Extra dependencies from .hs-boot files] {- Note [Extra dependencies from .hs-boot files]
......
...@@ -322,7 +322,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty ...@@ -322,7 +322,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
(not (isAbstractTyCon tc) && all in_scope data_con_names) (not (isAbstractTyCon tc) && all in_scope data_con_names)
where where
data_con_names = map dataConName (tyConDataCons tc) data_con_names = map dataConName (tyConDataCons tc)
in_scope dc = not $ null $ lookupGRE_Name rdr_env dc in_scope dc = isJust (lookupGRE_Name rdr_env dc)
{- {-
************************************************************************ ************************************************************************
......
...@@ -901,7 +901,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta ...@@ -901,7 +901,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
(isAbstractTyCon rep_tc || (isAbstractTyCon rep_tc ||
any not_in_scope data_con_names) any not_in_scope data_con_names)
not_in_scope dc = null (lookupGRE_Name rdr_env dc) not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
; addUsedDataCons rdr_env rep_tc ; addUsedDataCons rdr_env rep_tc
; unless (isNothing mtheta || not hidden_data_cons) ; unless (isNothing mtheta || not hidden_data_cons)
......
...@@ -1244,7 +1244,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 ...@@ -1244,7 +1244,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
| isNewTyCon tc | isNewTyCon tc
, [data_con] <- tyConDataCons tc , [data_con] <- tyConDataCons tc
, let dc_name = dataConName data_con , let dc_name = dataConName data_con
, null (lookupGRE_Name rdr_env dc_name) , isNothing (lookupGRE_Name rdr_env dc_name)
= Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
, text "is not in scope" ]) , text "is not in scope" ])
......
...@@ -189,7 +189,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0 ...@@ -189,7 +189,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env tc checkNewtypeFFI rdr_env tc
| Just con <- tyConSingleDataCon_maybe tc | Just con <- tyConSingleDataCon_maybe tc
, [gre] <- lookupGRE_Name rdr_env (dataConName con) , Just gre <- lookupGRE_Name rdr_env (dataConName con)
= Just gre -- See Note [Newtype constructor usage in foreign declarations] = Just gre -- See Note [Newtype constructor usage in foreign declarations]
| otherwise | otherwise
= Nothing = Nothing
......
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