[project @ 1997-06-05 09:16:04 by sof]

[ghc-hetmet.git] / ghc / compiler / types / TyVar.lhs

diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index f59382a..0fdfc32 100644 (file)
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -2,20 +2,21 @@
 #include "HsVersions.h"
 
 module TyVar (
-       GenTyVar(..), TyVar(..),
-       mkTyVar,
-       getTyVarKind,           -- TyVar -> Kind
+       GenTyVar(..), SYN_IE(TyVar),
+       mkTyVar, mkSysTyVar,
+       tyVarKind,              -- TyVar -> Kind
        cloneTyVar,
 
+       openAlphaTyVar,
        alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
 
        -- We also export "environments" keyed off of
        -- TyVars and "sets" containing TyVars:
-       TyVarEnv(..),
+       SYN_IE(TyVarEnv),
        nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
-       growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
+       growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
 
-       GenTyVarSet(..), TyVarSet(..),
+       SYN_IE(GenTyVarSet), SYN_IE(TyVarSet),
        emptyTyVarSet, unitTyVarSet, unionTyVarSets,
        unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
        tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
@@ -23,24 +24,22 @@ module TyVar (
   ) where
 
 CHK_Ubiq()     -- debugging consistency check
-import IdLoop  -- for paranoia checking
 
 -- friends
-import Usage           ( GenUsage, Usage(..), usageOmega )
-import Kind            ( Kind, mkBoxedTypeKind )
+import Usage           ( GenUsage, SYN_IE(Usage), usageOmega )
+import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind )
 
 -- others
 import UniqSet         -- nearly all of it
 import UniqFM          ( emptyUFM, listToUFM, addToUFM, lookupUFM,
-                         plusUFM, sizeUFM, UniqFM
+                         plusUFM, sizeUFM, delFromUFM, UniqFM
                        )
-import Maybes          ( Maybe(..) )
-import NameTypes       ( ShortName )
-import Pretty          ( Pretty(..), PrettyRep, ppBeside, ppPStr )
-import PprStyle                ( PprStyle )
-import Outputable      ( Outputable(..), NamedThing(..), ExportFlag(..) )
-import SrcLoc          ( mkUnknownSrcLoc, SrcLoc )
+import Name            ( mkSysLocalName, changeUnique, Name, NamedThing(..) )
+import Pretty          ( Doc, (<>), ptext )
+import Outputable      ( PprStyle(..), Outputable(..) )
+import SrcLoc          ( noSrcLoc, SrcLoc )
 import Unique          ( showUnique, mkAlphaTyVarUnique, Unique )
+import UniqFM           ( Uniquable(..) )
 import Util            ( panic, Ord3(..) )
 \end{code}
 
@@ -49,7 +48,7 @@ data GenTyVar flexi_slot
   = TyVar
        Unique
        Kind
-       (Maybe ShortName)       -- User name (if any)
+       (Maybe Name)            -- User name (if any)
        flexi_slot              -- Extra slot used during type and usage
                                -- inference, and to contain usages.
 
@@ -60,14 +59,20 @@ type TyVar = GenTyVar Usage -- Usage slot makes sense only if Kind = Type
 Simple construction and analysis functions
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-mkTyVar :: ShortName -> Unique -> Kind -> TyVar
-mkTyVar name uniq kind = TyVar  uniq
-                               kind
-                               (Just name)
-                               usageOmega
+mkTyVar :: Name -> Kind -> TyVar
+mkTyVar name kind = TyVar  (uniqueOf name)
+                          kind
+                          (Just name)
+                          usageOmega
 
-getTyVarKind :: GenTyVar flexi -> Kind
-getTyVarKind (TyVar _ kind _ _) = kind
+mkSysTyVar :: Unique -> Kind -> TyVar
+mkSysTyVar uniq kind = TyVar uniq
+                            kind
+                            Nothing
+                            usageOmega
+
+tyVarKind :: GenTyVar flexi -> Kind
+tyVarKind (TyVar _ kind _ _) = kind
 
 cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi
 cloneTyVar (TyVar _ k n x) u = TyVar u k n x
@@ -77,10 +82,16 @@ cloneTyVar (TyVar _ k n x) u = TyVar u k n x
 Fixed collection of type variables
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
+       -- openAlphaTyVar is prepared to be instantiated
+       -- to a boxed or unboxed type variable.  It's used for the 
+       -- result type for "error", so that we can have (error Int# "Help")
+openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing usageOmega
+
 alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega
-             | u <- map mkAlphaTyVarUnique [1..] ]
+             | u <- map mkAlphaTyVarUnique [2..] ]
 
 (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+
 \end{code}
 
 
@@ -95,11 +106,13 @@ addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
 growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
 isNullTyVarEnv  :: TyVarEnv a -> Bool
 lookupTyVarEnv  :: TyVarEnv a -> GenTyVar flexi -> Maybe a
+delFromTyVarEnv         :: TyVarEnv a -> GenTyVar flexi -> TyVarEnv a
 
 nullTyVarEnv    = emptyUFM
 mkTyVarEnv      = listToUFM
 addOneToTyVarEnv = addToUFM
 lookupTyVarEnv   = lookupUFM
+delFromTyVarEnv  = delFromUFM
 
 growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
 isNullTyVarEnv   env      = sizeUFM env == 0
@@ -143,20 +156,10 @@ instance Eq (GenTyVar a) where
 instance Ord3 (GenTyVar a) where
     cmp (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `cmp` u2
 
-instance NamedThing (GenTyVar a) where
-    getExportFlag      (TyVar _ _ _ _) = NotExported
-    isLocallyDefined   (TyVar _ _ _ _) = True
-
-    getOrigName                (TyVar _ _ (Just n) _) = getOrigName n
-    getOrigName                (TyVar u _ _        _) = (panic "getOrigName:TyVar",
-                                                 showUnique u)
-    getOccurrenceName  (TyVar _ _ (Just n) _) = getOccurrenceName n
-    getOccurrenceName  (TyVar u _ _        _) = showUnique u
-
-    getSrcLoc          (TyVar _ _ (Just n) _) = getSrcLoc n
-    getSrcLoc          (TyVar _ _ _        _) = mkUnknownSrcLoc
-    fromPreludeCore    (TyVar _ _ _ _)        = False
-
-    getItsUnique       (TyVar u _ _ _)        = u
+instance Uniquable (GenTyVar a) where
+    uniqueOf (TyVar u _ _ _) = u
 
+instance NamedThing (GenTyVar a) where
+    getName (TyVar _ _ (Just n) _) = n
+    getName (TyVar u _ _        _) = mkSysLocalName u SLIT("t") noSrcLoc
 \end{code}