[project @ 2000-12-07 08:17:55 by simonpj]

[ghc-hetmet.git] / ghc / compiler / basicTypes / OccName.lhs

diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index 6a1de96..805bdf5 100644 (file)
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -8,7 +8,7 @@
 module OccName (
        -- The NameSpace type; abstact
        NameSpace, tcName, clsName, tcClsName, dataName, varName, ipName,
-       tvName, uvName, nameSpaceString, 
+       tvName, nameSpaceString, 
 
        -- The OccName type
        OccName,        -- Abstract, instance of Outputable
@@ -20,7 +20,7 @@ module OccName (
        mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
        mkGenOcc1, mkGenOcc2, 
        
-       isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
+       isSysOcc, isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
 
        occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, 
        setOccNameSpace,
@@ -40,7 +40,7 @@ module OccName (
 
 #include "HsVersions.h"
 
-import Char    ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
+import Char    ( isDigit, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
 import Util    ( thenCmp )
 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
 import Outputable
@@ -86,7 +86,6 @@ data NameSpace = VarName      -- Variables
               | IPName         -- Implicit Parameters
               | DataName       -- Data constructors
               | TvName         -- Type variables
-              | UvName         -- Usage variables
               | TcClsName      -- Type constructors and classes; Haskell has them
                                -- in the same name space for now.
               deriving( Eq, Ord )
@@ -99,7 +98,6 @@ tcClsName = TcClsName         -- Not sure which!
 
 dataName = DataName
 tvName   = TvName
-uvName   = UvName
 varName  = VarName
 ipName   = IPName
 
@@ -109,7 +107,6 @@ nameSpaceString DataName  = "Data constructor"
 nameSpaceString VarName   = "Variable"
 nameSpaceString IPName    = "Implicit Param"
 nameSpaceString TvName    = "Type variable"
-nameSpaceString UvName    = "Usage variable"
 nameSpaceString TcClsName = "Type constructor or class"
 \end{code}
 
@@ -177,7 +174,7 @@ mkCCallOcc :: EncodedString -> OccName
 -- But then alreadyEncoded complains about the braces!
 mkCCallOcc str = OccName varName (_PK_ str)
 
--- Kind constructors get a speical function.  Uniquely, they are not encoded,
+-- Kind constructors get a special function.  Uniquely, they are not encoded,
 -- so that they have names like '*'.  This means that *even in interface files*
 -- we'll get kinds like (* -> (* -> *)).  We can't use mkSysOcc because it
 -- has an ASSERT that doesn't hold.
@@ -225,14 +222,11 @@ occNameFlavour (OccName sp _) = nameSpaceString sp
 \end{code}
 
 \begin{code}
-isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool
+isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
 
 isTvOcc (OccName TvName _) = True
 isTvOcc other              = False
 
-isUvOcc (OccName UvName _) = True
-isUvOcc other              = False
-
 isValOcc (OccName VarName  _) = True
 isValOcc (OccName DataName _) = True
 isValOcc other               = False
@@ -332,17 +326,9 @@ mkSuperDictSelOcc index cls_occ
 
 \begin{code}
 mkDFunOcc :: EncodedString     -- Typically the class and type glommed together e.g. "OrdMaybe"
-         -> Int                -- Unique to distinguish dfuns which share the previous two
-                               --      eg 3
-         -- The requirement is that the (string,index) pair be unique in this module
-
-         -> OccName    -- "$fOrdMaybe3"
+         -> OccName            -- "$fOrdMaybe"
 
-mkDFunOcc string index
-  = mk_deriv VarName "$f" (show_index ++ string)
-  where
-    show_index | index == 0 = ""
-              | otherwise  = show index
+mkDFunOcc string = mk_deriv VarName "$f" string
 \end{code}
 
 We used to add a '$m' to indicate a method, but that gives rise to bad
@@ -455,8 +441,11 @@ The basic encoding scheme is this.
        fooZ            fooZZ   
        :+              Zczp
        ()              Z0T
-       (,,,,)          Z4T
-
+       (,,,,)          Z4T     5-tuple
+       (#,,,,#)        Z4H     unboxed 5-tuple
+               (NB: the number is one different to the number of 
+               elements.  No real reason except that () is a zero-tuple,
+               while (,) is a 2-tuple.)
 
 \begin{code}
 -- alreadyEncoded is used in ASSERTs to check for encoded
@@ -477,20 +466,23 @@ alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs)
 
 encode :: UserString -> EncodedString
 encode cs = case maybe_tuple cs of
-               Just n  -> 'Z' : show n ++ "T"          -- Tuples go to Z2T etc
+               Just n  -> n            -- Tuples go to Z2T etc
                Nothing -> go cs
          where
                go []     = []
                go (c:cs) = encode_ch c ++ go cs
 
--- ToDo: Unboxed tuples too, perhaps?
-maybe_tuple ('(' : cs) = check_tuple (0::Int) cs
-maybe_tuple other      = Nothing
+maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
+                                (n, '#' : ')' : cs) -> Just ('Z' : shows n "H")
+                                other               -> Nothing
+maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of
+                                (n, ')' : cs) -> Just ('Z' : shows n "T")
+                                other         -> Nothing
+maybe_tuple other           = Nothing
 
-check_tuple :: Int -> String -> Maybe Int
-check_tuple n (',' : cs) = check_tuple (n+1) cs
-check_tuple n ")"       = Just n
-check_tuple n other      = Nothing
+count_commas :: Int -> String -> (Int, String)
+count_commas n (',' : cs) = count_commas (n+1) cs
+count_commas n cs        = (n,cs)
 
 encodeFS :: UserFS -> EncodedFS
 encodeFS fast_str  | all unencodedChar str = fast_str
@@ -585,6 +577,7 @@ decode_escape (c : rest)
   where
     go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
     go n ('T' : rest)          = '(' : replicate n ',' ++ ')' : decode rest
+    go n ('H' : rest)          = '(' : '#' : replicate n ',' ++ '#' : ')' : decode rest
     go n ('U' : rest)           = chr n : decode rest
     go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest))