Merge branch 'master' of http://darcs.haskell.org/ghc

Conflicts:
	compiler/basicTypes/DataCon.lhs

3 files changed, 30 insertions, 24 deletions

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 1d3a7f9d9b..261d10295f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1411,11 +1411,11 @@ repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156
 
 -- Type-level naturals
-typeNatKindConNameKey, typeStringKindConNameKey,
+typeNatKindConNameKey, typeSymbolKindConNameKey,
   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey
   :: Unique
 typeNatKindConNameKey     = mkPreludeTyConUnique 160
-typeStringKindConNameKey  = mkPreludeTyConUnique 161
+typeSymbolKindConNameKey  = mkPreludeTyConUnique 161
 typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
 typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index d94de113e4..e83fcb5255 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -65,7 +65,7 @@ module TysWiredIn (
 	unitTy,
 
         -- * Kinds
-	typeNatKindCon, typeNatKind, typeStringKindCon, typeStringKind,
+	typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
 
         -- * Parallel arrays
 	mkPArrTy,
@@ -152,7 +152,7 @@ wiredInTyCons = [ unitTyCon	-- Not treated like other tuples, because
 	      , parrTyCon
               , eqTyCon
               , typeNatKindCon
-              , typeStringKindCon
+              , typeSymbolKindCon
     	      ]
            ++ (case cIntegerLibraryType of
                IntegerGMP -> [integerTyCon]
@@ -199,9 +199,9 @@ doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double")
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
 -- Kinds
-typeNatKindConName, typeStringKindConName :: Name
+typeNatKindConName, typeSymbolKindConName :: Name
 typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon
-typeStringKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey typeStringKindCon 
+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon 
 
 -- For integer-gmp only:
 integerRealTyConName :: Name
@@ -240,23 +240,22 @@ eqTyCon_RDR     = nameRdrName eqTyConName
 
 \begin{code}
 pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcNonRecDataTyCon = pcTyCon False NonRecursive
-pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcRecDataTyCon    = pcTyCon False Recursive
+-- Not an enumeration, not promotable
+pcNonRecDataTyCon = pcTyCon False NonRecursive False
 
-pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcTyCon is_enum is_rec name cType tyvars cons
+pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
+pcTyCon is_enum is_rec is_prom name cType tyvars cons
   = tycon
   where
-    tycon = mkAlgTyCon name
-		(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
+    tycon = buildAlgTyCon name
                 tyvars
                 cType
                 []		-- No stupid theta
 		(DataTyCon cons is_enum)
-		NoParentTyCon
                 is_rec
+                is_prom
 		False		-- Not in GADT syntax
+		NoParentTyCon
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
 pcDataCon = pcDataConWithFixity False
@@ -305,15 +304,15 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
 %************************************************************************
 
 \begin{code}
-typeNatKindCon, typeStringKindCon :: TyCon 
+typeNatKindCon, typeSymbolKindCon :: TyCon 
 -- data Nat
 -- data Symbol
-typeNatKindCon    = pcNonRecDataTyCon typeNatKindConName    Nothing [] []
-typeStringKindCon = pcNonRecDataTyCon typeStringKindConName Nothing [] []
+typeNatKindCon    = pcTyCon False NonRecursive True typeNatKindConName    Nothing [] []
+typeSymbolKindCon = pcTyCon False NonRecursive True typeSymbolKindConName Nothing [] []
 
-typeNatKind, typeStringKind :: Kind
+typeNatKind, typeSymbolKind :: Kind
 typeNatKind    = TyConApp (promoteTyCon typeNatKindCon)    []
-typeStringKind = TyConApp (promoteTyCon typeStringKindCon) []
+typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) []
 \end{code}
 
 
@@ -368,7 +367,12 @@ factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [
 mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
 mk_tuple sort arity = (tycon, tuple_con)
   where
-	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort 
+	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc
+        prom_tc = case sort of
+	  BoxedTuple   	  -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
+	  UnboxedTuple 	  -> Nothing
+	  ConstraintTuple -> Nothing
+
 	modu	= mkTupleModule sort arity
 	tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
 				(ATyCon tycon) BuiltInSyntax
@@ -434,6 +438,7 @@ eqTyCon = mkAlgTyCon eqTyConName
             NoParentTyCon
             NonRecursive
             False
+            Nothing   -- No parent for constraint-kinded types
   where
     kv = kKiVar
     k = mkTyVarTy kv
@@ -579,7 +584,7 @@ boolTy :: Type
 boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
-boolTyCon = pcTyCon True NonRecursive boolTyConName
+boolTyCon = pcTyCon True NonRecursive True boolTyConName
                     (Just (CType Nothing (fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
@@ -592,7 +597,7 @@ falseDataConId = dataConWorkId falseDataCon
 trueDataConId  = dataConWorkId trueDataCon
 
 orderingTyCon :: TyCon
-orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing
+orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing
                         [] [ltDataCon, eqDataCon, gtDataCon]
 
 ltDataCon, eqDataCon, gtDataCon :: DataCon
@@ -626,7 +631,8 @@ mkListTy :: Type -> Type
 mkListTy ty = mkTyConApp listTyCon [ty]
 
 listTyCon :: TyCon
-listTyCon = pcRecDataTyCon listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
+listTyCon = pcTyCon False Recursive True
+                    listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
 
 mkPromotedListTy :: Type -> Type
 mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
diff --git a/compiler/prelude/TysWiredIn.lhs-boot b/compiler/prelude/TysWiredIn.lhs-boot
index 65c03c8e17..b6dab8a21b 100644
--- a/compiler/prelude/TysWiredIn.lhs-boot
+++ b/compiler/prelude/TysWiredIn.lhs-boot
@@ -6,6 +6,6 @@ import {-# SOURCE #-} TypeRep    (Type)
 
 
 eqTyCon :: TyCon
-typeNatKind, typeStringKind :: Type
+typeNatKind, typeSymbolKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
 \end{code}