[commit: ghc] type-nats: Fix the names of the type function constructors (XXX). (a4d5a1c)

[Iavor Diatchki]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/a4d5a1c7d7217587ed8dc8b5835b9f05969955d6

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

commit a4d5a1c7d7217587ed8dc8b5835b9f05969955d6
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sun May 13 19:07:45 2012 -0700

    Fix the names of the type function constructors (XXX).
    
    This is still does not seem right---these constructors are not
    primitive but "wired-in".  However, I could not define them in the
    "wired in" module because it depends on module `Coercion`, which
    needs to use the constructors...

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

 compiler/prelude/TysPrim.lhs |   38 ++++++++++++++++++++++++++++----------
 1 files changed, 28 insertions(+), 10 deletions(-)

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 8991871..edc859c 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -81,7 +81,7 @@ module TysPrim(
 	anyTy, anyTyCon, anyTypeOfKind,
 
         -- * Type families used to compute at the type level.
-        typeNatAddTyCon, typeNatMulTyCon, typeNatExpTyCon
+        typeNatLeqTyCon, typeNatAddTyCon, typeNatMulTyCon, typeNatExpTyCon
 
   ) where
 
@@ -97,6 +97,8 @@ import Unique		( mkAlphaTyVarUnique )
 import PrelNames
 import FastString
 
+import BasicTypes (RecFlag(..))
+
 import Data.Char
 \end{code}
 
@@ -370,10 +372,14 @@ ubxTupleKind     = kindTyConType ubxTupleKindTyCon
 constraintKind   = kindTyConType constraintKindTyCon
 
 typeNatKind :: Kind
-typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind)
+typeNatKind = kindTyConType (mkPromotedTyCon alg superKind)
+  where alg = mkAlgTyCon typeNatKindConName openTypeKind [] Nothing []
+                          (AbstractTyCon True) NoParentTyCon NonRecursive False
 
 typeStringKind :: Kind
-typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind)
+typeStringKind = kindTyConType (mkPromotedTyCon alg superKind)
+  where alg = mkAlgTyCon typeStringKindConName openTypeKind [] Nothing []
+                         (AbstractTyCon True) NoParentTyCon NonRecursive False
 
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
 mkArrowKind :: Kind -> Kind -> Kind
@@ -749,17 +755,29 @@ anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
 Type functions related to type-nats.
 
 \begin{code}
+
+-- XXX: THIS IS WRONG.  IT SHOULD RETURN A PROMOTED BOOL.
+typeNatLeqTyCon :: TyCon
+typeNatLeqTyCon = mkSynTyCon typeNatLeqTyFamName
+                    (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind)
+                    (take 2 $ tyVarList typeNatKind)
+                    SynFamilyTyCon
+                    NoParentTyCon
+
+mkTypeNatFunTyCon :: Name -> TyCon
+mkTypeNatFunTyCon op = mkSynTyCon op
+                    (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind)
+                    (take 2 $ tyVarList typeNatKind)
+                    SynFamilyTyCon
+                    NoParentTyCon
+
 typeNatAddTyCon :: TyCon
-typeNatAddTyCon = mkFunTyCon typeNatAddTyFamName
-                $ mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind
+typeNatAddTyCon = mkTypeNatFunTyCon typeNatAddTyFamName
 
 typeNatMulTyCon :: TyCon
-typeNatMulTyCon = mkFunTyCon typeNatMulTyFamName
-                $ mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind
+typeNatMulTyCon = mkTypeNatFunTyCon typeNatMulTyFamName
 
 typeNatExpTyCon :: TyCon
-typeNatExpTyCon = mkFunTyCon typeNatExpTyFamName
-                $ mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind
-
+typeNatExpTyCon = mkTypeNatFunTyCon typeNatExpTyFamName
 \end{code}