[commit: ghc] type-nats-simple: Fixup how we create the wired-in names for type-level function tycons. (500a7f7)

[git at git.haskell.org]

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

On branch  : type-nats-simple
Link       : http://ghc.haskell.org/trac/ghc/changeset/500a7f7e671e8e0c62d51e855cd3ddec3471811a/ghc

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

commit 500a7f7e671e8e0c62d51e855cd3ddec3471811a
Author: Iavor S. Diatchki <diatchki at galois.com>
Date:   Wed Sep 4 11:55:09 2013 -0700

    Fixup how we create the wired-in names for type-level function tycons.
    
    Now they are all declared in TcTypeNats, because they contain the
    actual tycons, which are delcared there.


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

500a7f7e671e8e0c62d51e855cd3ddec3471811a
 compiler/prelude/PrelNames.lhs    |   11 +----------
 compiler/prelude/TysWiredIn.lhs   |    2 ++
 compiler/typecheck/TcRnDriver.lhs |    1 +
 compiler/typecheck/TcTypeNats.hs  |   26 ++++++++++++++++++--------
 4 files changed, 22 insertions(+), 18 deletions(-)

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 3e5384b..24558f0 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -289,10 +289,6 @@ basicKnownKeyNames
 
         -- Type-level naturals
         singIClassName,
-        typeNatLeqClassName,
-        typeNatAddTyFamName,
-        typeNatMulTyFamName,
-        typeNatExpTyFamName,
 
         -- Implicit parameters
         ipClassName,
@@ -1120,13 +1116,8 @@ randomGenClassName  = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey
 isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey
 
 -- Type-level naturals
-singIClassName, typeNatLeqClassName,
-  typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name
+singIClassName :: Name
 singIClassName      = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey
-typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=")  typeNatLeqClassNameKey
-typeNatAddTyFamName = tcQual  gHC_TYPELITS (fsLit "+")   typeNatAddTyFamNameKey
-typeNatMulTyFamName = tcQual  gHC_TYPELITS (fsLit "*")   typeNatMulTyFamNameKey
-typeNatExpTyFamName = tcQual  gHC_TYPELITS (fsLit "^")   typeNatExpTyFamNameKey
 
 -- Implicit parameters
 ipClassName :: Name
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 5ec290a..0a39228 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -68,6 +68,8 @@ module TysWiredIn (
         -- * Equality predicates
         eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
 
+        mkWiredInTyConName -- This is used in TcTypeNats to define the
+                           -- built-in functions for evaluation.
     ) where
 
 #include "HsVersions.h"
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index b5bf4a7..5df26a2 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -774,6 +774,7 @@ checkBootTyCon tc1 tc2
             = eqClosedFamilyAx ax1 ax2
         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
             = eqTypeX env t1 t2
+        eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
         eqSynRhs _ _ = False
     in
     roles1 == roles2 &&
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 7356e67..7f5c8a6 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -11,14 +11,15 @@ import CoAxiom    ( CoAxiomRule(..) )
 import Name       ( Name, mkWiredInName, BuiltInSyntax(..) )
 import OccName    ( mkOccName, tcName )
 import Unique     ( mkAxiomRuleUnique )
-import TysWiredIn ( typeNatKind )
+import TysWiredIn ( typeNatKind, mkWiredInTyConName )
 import TysPrim    ( tyVarList, mkArrowKinds )
-import PrelNames  ( gHC_PRIM
-                  , typeNatAddTyFamName
-                  , typeNatMulTyFamName
-                  , typeNatExpTyFamName
+import PrelNames  ( gHC_PRIM, gHC_TYPELITS
+                  , typeNatAddTyFamNameKey
+                  , typeNatMulTyFamNameKey
+                  , typeNatExpTyFamNameKey
                   )
 import FamInst(TcBuiltInSynFamily(..),trivialBuiltInFamily)
+import FastString ( fsLit )
 
 typeNatTyThings :: [TyThing]
 
@@ -37,28 +38,37 @@ typeNatTyCons = map ATyCon
   ]
 
 typeNatAddTyCon :: TyCon
-typeNatAddTyCon = mkTypeNatFunTyCon2 typeNatAddTyFamName
+typeNatAddTyCon = mkTypeNatFunTyCon2 name
   TcBuiltInSynFamily
     { sfMatchFam      = matchFamAdd
     , sfInteractTop   = interactTopAdd
     , sfInteractInert = sfInteractInert trivialBuiltInFamily
     }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "+")
+            typeNatAddTyFamNameKey typeNatAddTyCon
 
 typeNatMulTyCon :: TyCon
-typeNatMulTyCon = mkTypeNatFunTyCon2 typeNatMulTyFamName
+typeNatMulTyCon = mkTypeNatFunTyCon2 name
   TcBuiltInSynFamily
     { sfMatchFam      = matchFamMul
     , sfInteractTop   = interactTopMul
     , sfInteractInert = sfInteractInert trivialBuiltInFamily
     }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "*")
+            typeNatMulTyFamNameKey typeNatMulTyCon
 
 typeNatExpTyCon :: TyCon
-typeNatExpTyCon = mkTypeNatFunTyCon2 typeNatExpTyFamName
+typeNatExpTyCon = mkTypeNatFunTyCon2 name
   TcBuiltInSynFamily
     { sfMatchFam      = matchFamExp
     , sfInteractTop   = interactTopExp
     , sfInteractInert = sfInteractInert trivialBuiltInFamily
     }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "*")
+                typeNatExpTyFamNameKey typeNatExpTyCon
 
 -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
 mkTypeNatFunTyCon2 :: Name -> TcBuiltInSynFamily -> TyCon