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 <[email protected]> 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} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
