[commit: ghc] master: Fix #10872. (d459f55)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d459f55c36c50ae02c55a7fb1331ef81af6751f5/ghc

>---------------------------------------------------------------

commit d459f55c36c50ae02c55a7fb1331ef81af6751f5
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).


>---------------------------------------------------------------

d459f55c36c50ae02c55a7fb1331ef81af6751f5
 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