[commit: ghc] ghc-8.0: Fix #10872. (a1a054b)
git at git.haskell.org
git at git.haskell.org
Sat Jan 16 12:49:25 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/a1a054b1c91a4dc234d879064a0612eefdcd3fcf/ghc
>---------------------------------------------------------------
commit a1a054b1c91a4dc234d879064a0612eefdcd3fcf
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Sat Jan 9 16:59:05 2016 -0500
Fix #10872.
This moves the duplicate-unique check from knownKeyNames (which omits
TH) to allKnownKeyNames (which includes TH).
(cherry picked from commit d459f55c36c50ae02c55a7fb1331ef81af6751f5)
>---------------------------------------------------------------
a1a054b1c91a4dc234d879064a0612eefdcd3fcf
compiler/main/HscMain.hs | 33 ++++++++++++++++++++++++++++++---
compiler/prelude/PrelInfo.hs | 32 ++------------------------------
2 files changed, 32 insertions(+), 33 deletions(-)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 7807f65..f8945b2 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index 0651a2c..74005ed 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -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
More information about the ghc-commits
mailing list