Commit d459f55c authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #10872.

This moves the duplicate-unique check from knownKeyNames (which omits
TH) to allKnownKeyNames (which includes TH).
parent d4af57fa
......@@ -148,6 +148,8 @@ import DynFlags
import ErrUtils
import Outputable
import UniqFM
import NameEnv
import HscStats ( ppSourceStats )
import HscTypes
import FastString
......@@ -199,12 +201,37 @@ newHscEnv dflags = do
allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
allKnownKeyNames = -- where templateHaskellNames are defined
knownKeyNames
allKnownKeyNames -- where templateHaskellNames are defined
| debugIsOn
, not (isNullUFM badNamesEnv)
= panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
-- NB: We can't use ppr here, because this is sometimes evaluated in a
-- context where there are no DynFlags available, leading to a cryptic
-- "<<details unavailable>>" error. (This seems to happen only in the
-- stage 2 compiler, for reasons I [Richard] have no clue of.)
| otherwise
= all_names
where
all_names = knownKeyNames
#ifdef GHCI
++ templateHaskellNames
++ templateHaskellNames
#endif
namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM all_names
badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv
badNamesPairs = nameEnvUniqueElts badNamesEnv
badNamesStrs = map pairToStr badNamesPairs
badNamesStr = unlines badNamesStrs
pairToStr (uniq, ns) = " " ++
show uniq ++
": [" ++
intercalate ", " (map (occNameString . nameOccName) ns) ++
"]"
-- -----------------------------------------------------------------------------
getWarnings :: Hsc WarningMessages
......
......@@ -34,18 +34,14 @@ import DataCon
import Id
import Name
import MkId
import NameEnv
import TysPrim
import TysWiredIn
import HscTypes
import UniqFM
import Class
import TyCon
import Util
import Panic ( panic )
import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
import Data.List ( intercalate )
import Data.Array
{-
......@@ -81,19 +77,7 @@ knownKeyNames :: [Name]
-- you get a Name with the correct known key
-- (See Note [Known-key names] in PrelNames)
knownKeyNames
| debugIsOn
, not (isNullUFM badNamesEnv)
= panic ("badKnownKeyNames:\n" ++ badNamesStr)
-- NB: We can't use ppr here, because this is sometimes evaluated in a
-- context where there are no DynFlags available, leading to a cryptic
-- "<<details unavailable>>" error. (This seems to happen only in the
-- stage 2 compiler, for reasons I [Richard] have no clue of.)
| otherwise
= names
where
names =
concat [ tycon_kk_names funTyCon
= concat [ tycon_kk_names funTyCon
, concatMap tycon_kk_names primTyCons
, concatMap tycon_kk_names wiredInTyCons
......@@ -112,6 +96,7 @@ knownKeyNames
, map (idName . primOpId) allThePrimOps
, basicKnownKeyNames ]
where
-- "kk" short for "known-key"
tycon_kk_names :: TyCon -> [Name]
tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc))
......@@ -133,19 +118,6 @@ knownKeyNames
Just n -> [n]
Nothing -> []
namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM names
badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv
badNamesPairs = nameEnvUniqueElts badNamesEnv
badNamesStrs = map pairToStr badNamesPairs
badNamesStr = unlines badNamesStrs
pairToStr (uniq, ns) = " " ++
show uniq ++
": [" ++
intercalate ", " (map (occNameString . nameOccName) ns) ++
"]"
{-
We let a lot of "non-standard" values be visible, so that we can make
sense of them in interface pragmas. It's cool, though they all have
......
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