[project @ 1996-05-17 16:02:43 by partain]

[ghc-hetmet.git] / ghc / compiler / prelude / TysWiredIn.lhs

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 977758f..a4623c2 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -42,7 +42,7 @@ module TysWiredIn (
        liftTyCon,
        listTyCon,
        ltDataCon,
-       mallocPtrTyCon,
+       foreignObjTyCon,
        mkLiftTy,
        mkListTy,
        mkPrimIoTy,
@@ -68,7 +68,7 @@ module TysWiredIn (
        stateAndDoublePrimTyCon,
        stateAndFloatPrimTyCon,
        stateAndIntPrimTyCon,
-       stateAndMallocPtrPrimTyCon,
+       stateAndForeignObjPrimTyCon,
        stateAndMutableArrayPrimTyCon,
        stateAndMutableByteArrayPrimTyCon,
        stateAndPtrPrimTyCon,
@@ -81,12 +81,20 @@ module TysWiredIn (
        stringTyCon,
        trueDataCon,
        unitTy,
+       voidTy, voidTyCon,
        wordDataCon,
        wordTy,
        wordTyCon
 
     ) where
 
+--ToDo:rm
+--import Pretty
+--import Util
+--import PprType
+--import PprStyle
+--import Kind
+
 import Ubiq
 import TyLoop          ( mkDataCon, StrictnessMark(..) )
 
@@ -96,16 +104,16 @@ import TysPrim
 
 -- others:
 import SpecEnv         ( SpecEnv(..) )
-import NameTypes       ( mkPreludeCoreName, mkShortName )
 import Kind            ( mkBoxedTypeKind, mkArrowKind )
+import Name            ( mkBuiltinName )
 import SrcLoc          ( mkBuiltinSrcLoc )
 import TyCon           ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
                          NewOrData(..), TyCon
                        )
 import Type            ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
-                         mkFunTys, maybeAppDataTyCon,
+                         mkFunTys, maybeAppDataTyConExpandingDicts,
                          GenType(..), ThetaType(..), TauType(..) )
-import TyVar           ( getTyVarKind, alphaTyVar, betaTyVar )
+import TyVar           ( tyVarKind, alphaTyVar, betaTyVar )
 import Unique
 import Util            ( assoc, panic )
 
@@ -114,19 +122,21 @@ addOneToSpecEnv =  error "TysWiredIn:addOneToSpecEnv =  "
 pc_gen_specs = error "TysWiredIn:pc_gen_specs  "
 mkSpecInfo = error "TysWiredIn:SpecInfo"
 
-pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [Id] -> TyCon
-pcDataTyCon key mod name tyvars cons
-  = mkDataTyCon key tycon_kind full_name tyvars
-               [{-no context-}] cons [{-no derivings-}]
+pcDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING
+            -> [TyVar] -> [Id] -> TyCon
+pcDataTyCon key mod str tyvars cons
+  = mkDataTyCon (mkBuiltinName key mod str) tycon_kind 
+               tyvars [{-no context-}] cons [{-no derivings-}]
                DataType
   where
-    full_name = mkPreludeCoreName mod name
-    tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars
+    tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
 
-pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
-pcDataCon key mod name tyvars context arg_tys tycon specenv
-  = mkDataCon key (mkPreludeCoreName mod name)
+pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
+         -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
+pcDataCon key mod str tyvars context arg_tys tycon specenv
+  = mkDataCon (mkBuiltinName key mod str)
        [ NotMarkedStrict | a <- arg_tys ]
+       [ {- no labelled fields -} ]
        tyvars context arg_tys tycon
        -- specenv
 
@@ -144,6 +154,13 @@ pcGenerateDataSpecs ty
 %************************************************************************
 
 \begin{code}
+-- The Void type is represented as a data type with no constructors
+voidTy = mkTyConTy voidTyCon
+
+voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] []
+\end{code}
+
+\begin{code}
 charTy = mkTyConTy charTyCon
 
 charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon]
@@ -202,17 +219,17 @@ stablePtrTyCon
   where
     stablePtrDataCon
       = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
-           [alphaTyVar] [] [applyTyCon stablePtrPrimTyCon [alphaTy]] stablePtrTyCon nullSpecEnv
+           [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
-mallocPtrTyCon
-  = pcDataTyCon mallocPtrTyConKey gLASGOW_MISC SLIT("_MallocPtr")
-       [] [mallocPtrDataCon]
+foreignObjTyCon
+  = pcDataTyCon foreignObjTyConKey gLASGOW_MISC SLIT("_ForeignObj")
+       [] [foreignObjDataCon]
   where
-    mallocPtrDataCon
-      = pcDataCon mallocPtrDataConKey gLASGOW_MISC SLIT("_MallocPtr")
-           [] [] [applyTyCon mallocPtrPrimTyCon []] mallocPtrTyCon nullSpecEnv
+    foreignObjDataCon
+      = pcDataCon foreignObjDataConKey gLASGOW_MISC SLIT("_ForeignObj")
+           [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv
 \end{code}
 
 %************************************************************************
@@ -313,14 +330,14 @@ stateAndStablePtrPrimDataCon
                [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
                stateAndStablePtrPrimTyCon nullSpecEnv
 
-stateAndMallocPtrPrimTyCon
-  = pcDataTyCon stateAndMallocPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
-               [alphaTyVar] [stateAndMallocPtrPrimDataCon]
-stateAndMallocPtrPrimDataCon
-  = pcDataCon stateAndMallocPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
+stateAndForeignObjPrimTyCon
+  = pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
+               [alphaTyVar] [stateAndForeignObjPrimDataCon]
+stateAndForeignObjPrimDataCon
+  = pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
                [alphaTyVar] []
-               [mkStatePrimTy alphaTy, applyTyCon mallocPtrPrimTyCon []]
-               stateAndMallocPtrPrimTyCon nullSpecEnv
+               [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
+               stateAndForeignObjPrimTyCon nullSpecEnv
 
 stateAndFloatPrimTyCon
   = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
@@ -392,7 +409,7 @@ getStatePairingConInfo
            Type)       -- type of state pair
 
 getStatePairingConInfo prim_ty
-  = case (maybeAppDataTyCon prim_ty) of
+  = case (maybeAppDataTyConExpandingDicts prim_ty) of
       Nothing -> panic "getStatePairingConInfo:1"
       Just (prim_tycon, tys_applied, _) ->
        let
@@ -407,7 +424,7 @@ getStatePairingConInfo prim_ty
        (wordPrimTyCon, (stateAndWordPrimDataCon, stateAndWordPrimTyCon, 0)),
        (addrPrimTyCon, (stateAndAddrPrimDataCon, stateAndAddrPrimTyCon, 0)),
        (stablePtrPrimTyCon, (stateAndStablePtrPrimDataCon, stateAndStablePtrPrimTyCon, 0)),
-       (mallocPtrPrimTyCon, (stateAndMallocPtrPrimDataCon, stateAndMallocPtrPrimTyCon, 0)),
+       (foreignObjPrimTyCon, (stateAndForeignObjPrimDataCon, stateAndForeignObjPrimTyCon, 0)),
        (floatPrimTyCon, (stateAndFloatPrimDataCon, stateAndFloatPrimTyCon, 0)),
        (doublePrimTyCon, (stateAndDoublePrimDataCon, stateAndDoublePrimTyCon, 0)),
        (arrayPrimTyCon, (stateAndArrayPrimDataCon, stateAndArrayPrimTyCon, 0)),
@@ -431,13 +448,14 @@ This is really just an ordinary synonym, except it is ABSTRACT.
 mkStateTransformerTy s a = mkSynTy stTyCon [s, a]
 
 stTyCon
-  = mkSynTyCon
-     stTyConKey
-     (mkPreludeCoreName gLASGOW_ST SLIT("_ST"))
-     (panic "TysWiredIn.stTyCon:Kind")
-     2
-     [alphaTyVar, betaTyVar]
-     (mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]))
+  = let
+       ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
+    in
+    mkSynTyCon
+     (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST"))
+     (mkBoxedTypeKind `mkArrowKind` (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind))
+     2 [alphaTyVar, betaTyVar]
+     ty
 \end{code}
 
 %************************************************************************
@@ -452,13 +470,14 @@ stTyCon
 mkPrimIoTy a = mkSynTy primIoTyCon [a]
 
 primIoTyCon
-  = mkSynTyCon
-     primIoTyConKey
-     (mkPreludeCoreName pRELUDE_PRIMIO SLIT("PrimIO"))
-     (panic "TysWiredIn.primIoTyCon:Kind")
-     1
-     [alphaTyVar]
-     (mkStateTransformerTy realWorldTy alphaTy)
+  = let
+       ty = mkStateTransformerTy realWorldTy alphaTy
+    in
+--  pprTrace "primIOTyCon:" (ppCat [pprType PprDebug ty, ppr PprDebug (typeKind ty)]) $
+    mkSynTyCon
+     (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO"))
+     (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
+     1 [alphaTyVar] ty
 \end{code}
 
 %************************************************************************
@@ -512,10 +531,10 @@ primitive counterpart.
 \begin{code}
 boolTy = mkTyConTy boolTyCon
 
-boolTyCon = pcDataTyCon boolTyConKey pRELUDE_CORE SLIT("Bool") [] [falseDataCon, trueDataCon]
+boolTyCon = pcDataTyCon boolTyConKey pRELUDE SLIT("Bool") [] [falseDataCon, trueDataCon]
 
-falseDataCon = pcDataCon falseDataConKey pRELUDE_CORE SLIT("False") [] [] [] boolTyCon nullSpecEnv
-trueDataCon  = pcDataCon trueDataConKey         pRELUDE_CORE SLIT("True")  [] [] [] boolTyCon nullSpecEnv
+falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCon nullSpecEnv
+trueDataCon  = pcDataCon trueDataConKey         pRELUDE SLIT("True")  [] [] [] boolTyCon nullSpecEnv
 \end{code}
 
 %************************************************************************
@@ -641,20 +660,17 @@ rationalTy :: GenType t u
 mkRatioTy ty = applyTyCon ratioTyCon [ty]
 rationalTy   = mkRatioTy integerTy
 
-ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
+ratioTyCon = pcDataTyCon ratioTyConKey rATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
 
-ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%")
+ratioDataCon = pcDataCon ratioDataConKey rATIO SLIT(":%")
                [alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
        -- context omitted to match lib/prelude/ defn of "data Ratio ..."
 
 rationalTyCon
   = mkSynTyCon
-      rationalTyConKey
-      (mkPreludeCoreName pRELUDE_RATIO SLIT("Rational"))
+      (mkBuiltinName rationalTyConKey rATIO SLIT("Rational"))
       mkBoxedTypeKind
-      0         -- arity
-      [] -- tyvars
-      rationalTy -- == mkRatioTy integerTy
+      0        [] rationalTy -- == mkRatioTy integerTy
 \end{code}
 
 %************************************************************************
@@ -675,7 +691,7 @@ mkLiftTy ty
     (tvs, theta, tau) = splitSigmaTy ty
 
 isLiftTy ty
-  = case maybeAppDataTyCon tau of
+  = case (maybeAppDataTyConExpandingDicts tau) of
       Just (tycon, tys, _) -> tycon == liftTyCon
       Nothing -> False
   where
@@ -709,10 +725,7 @@ stringTy = mkListTy charTy
 
 stringTyCon
  = mkSynTyCon
-     stringTyConKey
-     (mkPreludeCoreName pRELUDE_CORE SLIT("String"))
+     (mkBuiltinName stringTyConKey pRELUDE SLIT("String"))
      mkBoxedTypeKind
-     0
-     []   -- type variables
-     stringTy
+     0 [] stringTy
 \end{code}