[project @ 2000-07-11 15:58:26 by simonmar]

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

diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index 7a59270..e2da548 100644 (file)
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -1,4 +1,4 @@
-
+%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
@@ -19,7 +19,7 @@ module OccName (
        mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
        mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
        
-       isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
+       isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
 
        occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, 
        setOccNameSpace,
@@ -68,10 +68,10 @@ type EncodedString = String -- Encoded form
 pprEncodedFS :: EncodedFS -> SDoc
 pprEncodedFS fs
   = getPprStyle        $ \ sty ->
-    if userStyle sty then
-       text (decode (_UNPK_ fs))
-    else
-       ptext fs
+    if userStyle sty
+       -- ptext (decodeFS fs) would needlessly pack the string again
+       then text (decode (_UNPK_ fs))
+        else ptext fs
 \end{code}
 
 %************************************************************************
@@ -310,6 +310,13 @@ mkSpecOcc     = mk_simple_deriv varName  "$s"
 mkForeignExportOcc = mk_simple_deriv varName  "$f"
 
 mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
+
+
+isSysOcc ::  OccName -> Bool   -- True for all these '$' things
+isSysOcc occ = case occNameUserString occ of
+                  ('$' : _ ) -> True
+                  other      -> False  -- We don't care about the ':' ones
+                                       -- isSysOcc is only called for Ids anyway
 \end{code}
 
 \begin{code}
@@ -428,23 +435,23 @@ The basic encoding scheme is this.
        and    'z', which translates to 'zz'
   We need both so that we can preserve the variable/tycon distinction
 
-* Most other printable characters translate to 'Zx' for some
+* Most other printable characters translate to 'zx' or 'Zx' for some
        alphabetic character x
 
-* The others translate as 'Zxdd' where 'dd' is exactly two hexadecimal
+* The others translate as 'zxdd' where 'dd' is exactly two hexadecimal
        digits for the ord of the character
 
        Before          After
        --------------------------
        Trak            Trak
-       foo_wib         foo_wib
-       >               Zg
-       >1              Zg1
-       foo#            fooZh
-       foo##           fooZhZh
-       foo##1          fooZhXh1
+       foo_wib         foozuwib
+       >               zg
+       >1              zg1
+       foo#            foozh
+       foo##           foozhzh
+       foo##1          foozhzh1
        fooZ            fooZZ   
-       :+              ZcZp
+       :+              Zczp
        ()              Z0T
        (,,,,)          Z4T
 
@@ -456,10 +463,11 @@ The basic encoding scheme is this.
 alreadyEncoded :: String -> Bool
 alreadyEncoded s = all ok s
                 where
-                  ok ' ' = True                -- This is a bit of a lie; if we really wanted spaces
-                                               -- in names we'd have to encode them.  But we do put
-                                               -- spaces in ccall "occurrences", and we don't want to
-                                               -- reject them here
+                  ok ' ' = True
+                       -- This is a bit of a lie; if we really wanted spaces
+                       -- in names we'd have to encode them.  But we do put
+                       -- spaces in ccall "occurrences", and we don't want to
+                       -- reject them here
                   ok ch  = ISALPHANUM ch
 
 alreadyEncodedFS :: FAST_STRING -> Bool
@@ -543,16 +551,17 @@ decode (c   : rest) = c : decode rest
 
 decode_escape :: EncodedString -> UserString
 
-decode_escape ('Z' : rest) = 'Z' : decode rest
-decode_escape ('C' : rest) = ':' : decode rest
 decode_escape ('L' : rest) = '(' : decode rest
 decode_escape ('R' : rest) = ')' : decode rest
 decode_escape ('M' : rest) = '[' : decode rest
 decode_escape ('N' : rest) = ']' : decode rest
+decode_escape ('C' : rest) = ':' : decode rest
+decode_escape ('Z' : rest) = 'Z' : decode rest
 
 decode_escape ('z' : rest) = 'z' : decode rest
 decode_escape ('a' : rest) = '&' : decode rest
 decode_escape ('b' : rest) = '|' : decode rest
+decode_escape ('c' : rest) = '^' : decode rest
 decode_escape ('d' : rest) = '$' : decode rest
 decode_escape ('e' : rest) = '=' : decode rest
 decode_escape ('g' : rest) = '>' : decode rest
@@ -566,7 +575,7 @@ decode_escape ('q' : rest) = '\'' : decode rest
 decode_escape ('r' : rest) = '\\' : decode rest
 decode_escape ('s' : rest) = '/' : decode rest
 decode_escape ('t' : rest) = '*' : decode rest
-decode_escape ('u' : rest) = '^' : decode rest
+decode_escape ('u' : rest) = '_' : decode rest
 decode_escape ('v' : rest) = '%' : decode rest
 decode_escape ('x' : d1 : d2 : rest) = chr (digitToInt d1 * 16 + digitToInt d2)  : decode rest
 
@@ -606,32 +615,29 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs
 isLexConId cs                          -- Prefix type or data constructors
   | _NULL_ cs       = False            --      e.g. "Foo", "[]", "(,)" 
   | cs == SLIT("[]") = True
-  | c  == '('       = True     -- (), (,), (,,), ...
-  | otherwise       = isUpper c || isUpperISO c
-  where                                        
-    c = _HEAD_ cs
+  | otherwise       = startsConId (_HEAD_ cs)
 
 isLexVarId cs                          -- Ordinary prefix identifiers
   | _NULL_ cs   = False                --      e.g. "x", "_x"
-  | otherwise    = isLower c || isLowerISO c || c == '_'
-  where
-    c = _HEAD_ cs
+  | otherwise    = startsVarId (_HEAD_ cs)
 
 isLexConSym cs                         -- Infix type or data constructors
   | _NULL_ cs  = False                 --      e.g. ":-:", ":", "->"
-  | otherwise  = c  == ':'
-              || cs == SLIT("->")
-  where
-    c = _HEAD_ cs
+  | cs == SLIT("->") = True
+  | otherwise  = startsConSym (_HEAD_ cs)
 
 isLexVarSym cs                         -- Infix identifiers
   | _NULL_ cs = False                  --      e.g. "+"
-  | otherwise = isSymbolASCII c
-            || isSymbolISO c
-  where
-    c = _HEAD_ cs
+  | otherwise = startsVarSym (_HEAD_ cs)
 
 -------------
+startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
+startsVarSym c = isSymbolASCII c || isSymbolISO c      -- Infix Ids
+startsConSym c = c == ':'                              -- Infix data constructors
+startsVarId c  = isLower c || isLowerISO c || c == '_' -- Ordinary Ids
+startsConId c  = isUpper c || isUpperISO c || c == '(' -- Ordinary type constructors and data constructors
+
+
 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
 isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
 isUpperISO    (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'#