-
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module OccName (
- -- Modules
- Module, -- Abstract, instance of Outputable
- mkModule, mkModuleFS, moduleString, moduleCString, pprModule,
+ -- The NameSpace type; abstact
+ NameSpace, tcName, clsName, tcClsName, dataName, varName,
+ tvName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
- varOcc, tcOcc, tvOcc, -- Occ constructors
- srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code
+ pprOccName,
- mkSuperDictSelOcc, mkDFunOcc,
- mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc,
+ mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
+ mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
+ mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
+ mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
+ mkGenOcc1, mkGenOcc2, mkLocalOcc,
- isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
- pprOccName, occNameString, occNameFlavour,
+ isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+
+ occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
+ setOccNameSpace,
- -- The basic form of names
- isLexCon, isLexVar, isLexId, isLexSym,
- isLexConId, isLexConSym, isLexVarId, isLexVarSym,
- isLowerISO, isUpperISO,
-
-- Tidying up
TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
- -- Junk
- identToC
+ -- Encoding
+ EncodedString, EncodedFS, UserString, UserFS, encode, encodeFS, decode, pprEncodedFS,
+
+ -- The basic form of names
+ isLexCon, isLexVar, isLexId, isLexSym,
+ isLexConId, isLexConSym, isLexVarId, isLexVarSym,
+ isLowerISO, isUpperISO
) where
#include "HsVersions.h"
-import Char ( isAlpha, isUpper, isLower, isAlphanum, ord )
+import Char ( isDigit, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt )
import Util ( thenCmp )
+import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
import Outputable
import GlaExts
\end{code}
+We hold both module names and identifier names in a 'Z-encoded' form
+that makes them acceptable both as a C identifier and as a Haskell
+(prefix) identifier.
-%************************************************************************
-%* *
-\subsection[Module]{The name of a module}
-%* *
-%************************************************************************
+They can always be decoded again when printing error messages
+or anything else for the user, but it does make sense for it
+to be represented here in encoded form, so that when generating
+code the encoding operation is not performed on each occurrence.
-\begin{code}
-data Module = Module FAST_STRING -- User and interface files
- FAST_STRING -- Print this in C files
-
- -- The C version has quote chars Z-encoded
+These type synonyms help documentation.
-instance Outputable Module where
- ppr = pprModule
+\begin{code}
+type UserFS = FAST_STRING -- As the user typed it
+type EncodedFS = FAST_STRING -- Encoded form
-instance Eq Module where
- (Module m1 _) == (Module m2 _) = m1 == m2
+type UserString = String -- As the user typed it
+type EncodedString = String -- Encoded form
-instance Ord Module where
- (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2
-pprModule :: Module -> SDoc
-pprModule (Module real code)
+pprEncodedFS :: EncodedFS -> SDoc
+pprEncodedFS fs
= getPprStyle $ \ sty ->
- if codeStyle sty then
- ptext code
- else
- ptext real
-
-mkModule :: String -> Module
-mkModule s = Module (_PK_ s) (identToC s)
-
-mkModuleFS :: FAST_STRING -> Module
-mkModuleFS s = Module s (identFsToC s)
+ if userStyle sty
+ -- ptext (decodeFS fs) would needlessly pack the string again
+ then text (decode (_UNPK_ fs))
+ else ptext fs
+\end{code}
-moduleString :: Module -> String
-moduleString (Module mod _) = _UNPK_ mod
+%************************************************************************
+%* *
+\subsection{Name space}
+%* *
+%************************************************************************
-moduleCString :: Module -> String
-moduleCString (Module _ code) = _UNPK_ code
+\begin{code}
+data NameSpace = VarName -- Variables
+ | DataName -- Data constructors
+ | TvName -- Type variables
+ | TcClsName -- Type constructors and classes; Haskell has them
+ -- in the same name space for now.
+ deriving( Eq, Ord )
+
+-- Though type constructors and classes are in the same name space now,
+-- the NameSpace type is abstract, so we can easily separate them later
+tcName = TcClsName -- Type constructors
+clsName = TcClsName -- Classes
+tcClsName = TcClsName -- Not sure which!
+
+dataName = DataName
+tvName = TvName
+varName = VarName
+
+
+nameSpaceString :: NameSpace -> String
+nameSpaceString DataName = "Data constructor"
+nameSpaceString VarName = "Variable"
+nameSpaceString TvName = "Type variable"
+nameSpaceString TcClsName = "Type constructor or class"
\end{code}
%************************************************************************
\begin{code}
-data OccName = OccName
- OccSpace
- FAST_STRING -- The 'real name'
- FAST_STRING -- Print this in interface files
- FAST_STRING -- Print this in C/asm code
-
--- The OccSpace/real-name pair define the OccName
--- The iface and c/asm versions are simply derived from the
--- other two. They are cached here simply to avoid recomputing
--- them repeatedly when printing
-
--- The latter two are irrelevant in RdrNames; on the other hand,
--- the OccSpace field is irrelevant after RdrNames.
--- So the OccName type might be refined a bit.
--- It is now abstract so that's easier than before
-
-
--- Why three print-names?
--- Real Iface C
--- ---------------------
--- foo foo foo
---
--- + + Zp Operators OK in interface files;
--- 'Z' is the escape char for C names
---
--- x# x# xZh Trailing # lexed ok by GHC -fglasgow-exts
---
--- _foo _ufoo _ufoo Leading '_' is the escape char in interface files
---
--- _vfoo _vfoo _vfoo Worker for foo
---
--- _wp _wp _wp Worker for +
-
-
-data OccSpace = VarOcc -- Variables and data constructors
- | TvOcc -- Type variables
- | TCOcc -- Type constructors and classes
- deriving( Eq, Ord )
+data OccName = OccName
+ NameSpace
+ EncodedFS
+\end{code}
+
+
+\begin{code}
+instance Eq OccName where
+ (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2
+
+instance Ord OccName where
+ compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp`
+ (sp1 `compare` sp2)
\end{code}
\begin{code}
instance Outputable OccName where
- ppr = pprOccName
+ ppr = pprOccName
pprOccName :: OccName -> SDoc
-pprOccName (OccName space real iface code)
- = getPprStyle $ \ sty ->
- if codeStyle sty then
- ptext code
- else if ifaceStyle sty then
- ptext iface
- else
- ptext real
+pprOccName (OccName sp occ) = pprEncodedFS occ
\end{code}
\subsection{Construction}
%* *
%************************************************************************
-
-*Source-code* things beginning with '_' are zapped to begin with '_u'
-\begin{code}
-mkSrcOcc :: OccSpace -> FAST_STRING -> OccName
-mkSrcOcc occ_sp real
- = case _UNPK_ real of
+*Sys* things do no encoding; the caller should ensure that the thing is
+already encoded
- '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str)
- where
- zapped_str = '_' : 'u' : rest
-
- other -> OccName occ_sp real real (identFsToC real)
-
-srcVarOcc, srcTCOcc, srcTvOcc :: FAST_STRING -> OccName
-srcVarOcc = mkSrcOcc VarOcc
-srcTCOcc = mkSrcOcc TCOcc
-srcTvOcc = mkSrcOcc TvOcc
+\begin{code}
+mkSysOcc :: NameSpace -> EncodedString -> OccName
+mkSysOcc occ_sp str = ASSERT2( alreadyEncoded str, text str )
+ OccName occ_sp (_PK_ str)
+
+mkSysOccFS :: NameSpace -> EncodedFS -> OccName
+mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
+ OccName occ_sp fs
+
+mkFCallOcc :: EncodedString -> OccName
+-- This version of mkSysOcc doesn't check that the string is already encoded,
+-- because it will be something like "{__ccall f dyn Int# -> Int#}"
+-- This encodes a lot into something that then parses like an Id.
+-- But then alreadyEncoded complains about the braces!
+mkFCallOcc str = OccName varName (_PK_ str)
+
+-- 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.
+mkKindOccFS :: NameSpace -> EncodedFS -> OccName
+mkKindOccFS occ_sp fs = OccName occ_sp fs
\end{code}
-However, things that don't come from Haskell source code aren't
-treated specially.
+*Source-code* things are encoded.
\begin{code}
-mkOcc :: OccSpace -> String -> OccName
-mkOcc occ_sp str = OccName occ_sp fs fs (identToC str)
- where
- fs = _PK_ str
-
-mkFsOcc :: OccSpace -> FAST_STRING -> OccName
-mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real)
+mkOccFS :: NameSpace -> UserFS -> OccName
+mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
-varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName
-varOcc = mkFsOcc VarOcc
-tcOcc = mkFsOcc TCOcc
-tvOcc = mkFsOcc TvOcc
+mkVarOcc :: UserFS -> OccName
+mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
\end{code}
+
%************************************************************************
%* *
-\subsection{Making system names}
+\subsection{Predicates and taking them apart}
%* *
%************************************************************************
-Here's our convention for splitting up the interface file name space:
-
- _d... dictionary identifiers
-
- _f... dict-fun identifiers (from inst decls)
- _g... ditto, when the tycon has symbols
-
- _t... externally visible (non-user visible) names
-
- _m... default methods
- _n... default methods (encoded symbols, eg. <= becomes _nle)
-
- _p... superclass selectors
-
- _v... workers
- _w... workers (encoded symbols)
-
- _x... local variables
-
- _u... user-defined names that previously began with '_'
-
- _T... compiler-generated tycons for dictionaries
- _D.. ...ditto data cons
-
- __.... keywords (__export, __letrec etc.)
-
-This knowledge is encoded in the following functions.
-
+\begin{code}
+occNameFS :: OccName -> EncodedFS
+occNameFS (OccName _ s) = s
+occNameString :: OccName -> EncodedString
+occNameString (OccName _ s) = _UNPK_ s
+occNameUserString :: OccName -> UserString
+occNameUserString occ = decode (occNameString occ)
-@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@;
- eg: workers, derived methods
+occNameSpace :: OccName -> NameSpace
+occNameSpace (OccName sp _) = sp
-We pass a character to use as the prefix. So, for example,
- "f" gets derived to "_vf", if the prefix char is 'v'
+setOccNameSpace :: OccName -> NameSpace -> OccName
+setOccNameSpace (OccName _ occ) sp = OccName sp occ
-\begin{code}
-mk_deriv :: OccSpace -> Char -> String -> OccName
-mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str)
+-- occNameFlavour is used only to generate good error messages
+occNameFlavour :: OccName -> String
+occNameFlavour (OccName sp _) = nameSpaceString sp
\end{code}
-Things are a bit more complicated if the thing is an operator; then
-we must encode it into a normal identifier first. We do this in
-a simple way, and use a different character prefix (one after the one
-suggested). For example
- "<" gets derived to "_wl", if the prefix char is 'v'
-
\begin{code}
-mk_enc_deriv :: OccSpace
- -> Char -- The system-name-space character (see list above)
- -> OccName -- The OccName from which we are deriving
- -> OccName
-
-mk_enc_deriv occ_sp sys_ch occ
- | needs_encoding real_str = mk_deriv occ_sp sys_op_ch (encode_operator real_str)
- | otherwise = mk_deriv occ_sp sys_ch real_str
- where
- real_str = occNameString occ
- sys_op_ch = succ sys_ch
+isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+isTvOcc (OccName TvName _) = True
+isTvOcc other = False
-mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc
- :: OccName -> OccName
+isTcOcc (OccName TcClsName _) = True
+isTcOcc other = False
-mkWorkerOcc = mk_enc_deriv VarOcc 'v' -- v,w
-mkDefaultMethodOcc = mk_enc_deriv VarOcc 'm' -- m,n
-mkClassTyConOcc = mk_enc_deriv TCOcc 'T' -- not U
-mkClassDataConOcc = mk_enc_deriv VarOcc 'D' -- not E
-mkDictOcc = mk_enc_deriv VarOcc 'd' -- not e
-\end{code}
+isValOcc (OccName VarName _) = True
+isValOcc (OccName DataName _) = True
+isValOcc other = False
-\begin{code}
-mkSuperDictSelOcc :: Int -- Index of superclass, eg 3
- -> OccName -- Class, eg "Ord"
- -> OccName -- eg "p3Ord"
-mkSuperDictSelOcc index cls_occ
- = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ)
-\end{code}
+-- Data constructor operator (starts with ':', or '[]')
+-- Pretty inefficient!
+isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
+isDataSymOcc other = False
+isDataOcc (OccName DataName _) = True
+isDataOcc other = False
-\begin{code}
-mkDFunOcc :: OccName -- class, eg "Ord"
- -> OccName -- tycon (or something convenient from the instance type)
- -- eg "Maybe"
- -> Int -- Unique to distinguish dfuns which share the previous two
- -- eg 3
- -> OccName -- "dOrdMaybe3"
-
-mkDFunOcc cls_occ tycon_occ index
- | needs_encoding tycon_str -- Drat! Have to encode the tycon
- = mk_deriv VarOcc 'g' (show_index ++ cls_str ++ encode_operator tycon_str)
- | otherwise -- Normal case
- = mk_deriv VarOcc 'f' (show_index ++ cls_str ++ tycon_str)
- where
- cls_str = occNameString cls_occ
- tycon_str = occNameString tycon_occ
- -- NB: if a non-operator the tycon has a trailing # we don't encode.
- show_index | index == 0 = ""
- | otherwise = show index
+-- Any operator (data constructor or variable)
+-- Pretty inefficient!
+isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
+isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
\end{code}
%************************************************************************
%* *
-\subsection{Lexical categories}
+\subsection{Making system names}
%* *
%************************************************************************
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
+Here's our convention for splitting up the interface file name space:
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+ d... dictionary identifiers
+ (local variables, so no name-clash worries)
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
+ $f... dict-fun identifiers (from inst decls)
+ $dm... default methods
+ $p... superclass selectors
+ $w... workers
+ :T... compiler-generated tycons for dictionaries
+ :D... ...ditto data cons
+ $sf.. specialised version of f
-isLexId cs = isLexConId cs || isLexVarId cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
+ in encoded form these appear as Zdfxxx etc
--------------
+ :... keywords (export:, letrec: etc.)
+--- I THINK THIS IS WRONG!
-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
+This knowledge is encoded in the following functions.
-isLexVarId cs -- Ordinary prefix identifiers
- | _NULL_ cs = False -- e.g. "x", "_x"
- | otherwise = isLower c || isLowerISO c || c == '_'
- where
- c = _HEAD_ cs
-isLexConSym cs -- Infix type or data constructors
- | _NULL_ cs = False -- e.g. ":-:", ":", "->"
- | otherwise = c == ':'
- || cs == SLIT("->")
- where
- c = _HEAD_ cs
+@mk_deriv@ generates an @OccName@ from the prefix and a string.
+NB: The string must already be encoded!
-isLexVarSym cs -- Infix identifiers
- | _NULL_ cs = False -- e.g. "+"
- | otherwise = isSymbolASCII c
- || isSymbolISO c
- where
- c = _HEAD_ cs
+\begin{code}
+mk_deriv :: NameSpace
+ -> String -- Distinguishes one sort of derived name from another
+ -> EncodedString -- Must be already encoded!! We don't want to encode it a
+ -- second time because encoding isn't idempotent
+ -> OccName
--------------
-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'#
- --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
- --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str)
\end{code}
-%************************************************************************
-%* *
-\subsection{Predicates and taking them apart}
-%* *
-%************************************************************************
-
-\begin{code}
-occNameString :: OccName -> String
-occNameString (OccName _ s _ _) = _UNPK_ s
+\begin{code}
+mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc
+ :: OccName -> OccName
--- occNameFlavour is used only to generate good error messages, so it doesn't matter
--- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for
--- data constructors and values, but that makes everything else a bit more complicated.
-occNameFlavour :: OccName -> String
-occNameFlavour (OccName VarOcc s _ _) | isLexConId s = "Data constructor"
- | otherwise = "Value"
-occNameFlavour (OccName TvOcc _ _ _) = "Type variable"
-occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class"
+-- These derived variables have a prefix that no Haskell value could have
+mkWorkerOcc = mk_simple_deriv varName "$w"
+mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
+mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
+mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon
+mkClassDataConOcc = mk_simple_deriv dataName ":D" --
+mkDictOcc = mk_simple_deriv varName "$d"
+mkIPOcc = mk_simple_deriv varName "$i"
+mkSpecOcc = mk_simple_deriv varName "$s"
+mkForeignExportOcc = mk_simple_deriv varName "$f"
+mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics
+mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics
+mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
+\end{code}
-isVarOcc, isTCOcc, isTvOcc,
- isConSymOcc, isSymOcc :: OccName -> Bool
+\begin{code}
+mkSuperDictSelOcc :: Int -- Index of superclass, eg 3
+ -> OccName -- Class, eg "Ord"
+ -> OccName -- eg "$p3Ord"
+mkSuperDictSelOcc index cls_occ
+ = mk_deriv varName "$p" (show index ++ occNameString cls_occ)
+
+mkLocalOcc :: Unique -- Unique
+ -> OccName -- Local name (e.g. "sat")
+ -> OccName -- Nice unique version ("$L23sat")
+mkLocalOcc uniq occ
+ = mk_deriv varName ("$L" ++ show uniq) (occNameString occ)
+ -- The Unique might print with characters
+ -- that need encoding (e.g. 'z'!)
+\end{code}
-isVarOcc (OccName VarOcc _ _ _) = True
-isVarOcc other = False
-isTvOcc (OccName TvOcc _ _ _) = True
-isTvOcc other = False
+\begin{code}
+mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe"
+ -> OccName -- "$fOrdMaybe"
-isTCOcc (OccName TCOcc _ _ _) = True
-isTCOcc other = False
+mkDFunOcc string = mk_deriv VarName "$f" string
+\end{code}
-isConSymOcc (OccName _ s _ _) = isLexConSym s
+We used to add a '$m' to indicate a method, but that gives rise to bad
+error messages from the type checker when we print the function name or pattern
+of an instance-decl binding. Why? Because the binding is zapped
+to use the method name in place of the selector name.
+(See TcClassDcl.tcMethodBind)
-isSymOcc (OccName _ s _ _) = isLexSym s
+The way it is now, -ddump-xx output may look confusing, but
+you can always say -dppr-debug to get the uniques.
-isConOcc (OccName _ s _ _) = isLexCon s
-\end{code}
+However, we *do* have to zap the first character to be lower case,
+because overloaded constructors (blarg) generate methods too.
+And convert to VarName space
+e.g. a call to constructor MkFoo where
+ data (Ord a) => Foo a = MkFoo a
-%************************************************************************
-%* *
-\subsection{Comparison}
-%* *
-%************************************************************************
-
-Comparison is done by space and 'real' name
+If this is necessary, we do it by prefixing '$m'. These
+guys never show up in error messages. What a hack.
\begin{code}
-instance Eq OccName where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord OccName where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
-
- compare (OccName sp1 r1 _ _) (OccName sp2 r2 _ _)
- = (sp1 `compare` sp2) `thenCmp` (r1 `compare` r2)
+mkMethodOcc :: OccName -> OccName
+mkMethodOcc occ@(OccName VarName fs) = occ
+mkMethodOcc occ = mk_simple_deriv varName "$m" occ
\end{code}
emptyTidyOccEnv = emptyFM
initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
-initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv
+initTidyOccEnv = foldl (\env (OccName _ fs) -> addToFM env fs 1) emptyTidyOccEnv
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
-tidyOccName in_scope occ@(OccName occ_sp real _ _)
- | not (real `elemFM` in_scope) &&
- not (isLexCon real) -- Hack alert! Specialised versions of overloaded
- -- constructors end up as ordinary Ids, but we don't
- -- want them as ConIds in interface files.
-
- = (addToFM in_scope real 1, occ) -- First occurrence
+tidyOccName in_scope occ@(OccName occ_sp fs)
+ | not (fs `elemFM` in_scope)
+ = (addToFM in_scope fs 1, occ) -- First occurrence
| otherwise -- Already occurs
- = -- First encode, to deal with
- -- a) operators, and
- -- b) trailing # signs
- -- so that we can then append '1', '2', etc
- go in_scope (encode_operator (_UNPK_ real))
+ = go in_scope (_UNPK_ fs)
where
go in_scope str = case lookupFM in_scope pk_str of
-- Need to go round again, just in case "t3" (say)
-- clashes with a "t3" that's already in scope
- Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str)
+ Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str)
-- str is now unique
where
pk_str = _PK_ str
%************************************************************************
%* *
-\subsection{Encoding for operators in derived names}
+\subsection{The 'Z' encoding}
%* *
%************************************************************************
-See comments with mk_enc_deriv
+This is the main name-encoding and decoding function. It encodes any
+string into a string that is acceptable as a C name. This is the name
+by which things are known right through the compiler.
+
+The basic encoding scheme is this.
+
+* Tuples (,,,) are coded as Z3T
+
+* Alphabetic characters (upper and lower) and digits
+ all translate to themselves;
+ except 'Z', which translates to 'ZZ'
+ 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' or 'Zx' for some
+ alphabetic character x
+
+* The others translate as 'znnnU' where 'nnn' is the decimal number
+ of the character
+
+ Before After
+ --------------------------
+ Trak Trak
+ foo_wib foozuwib
+ > zg
+ >1 zg1
+ foo# foozh
+ foo## foozhzh
+ foo##1 foozhzh1
+ fooZ fooZZ
+ :+ ZCzp
+ () Z0T 0-tuple
+ (,,,,) Z5T 5-tuple
+ (# #) Z1H unboxed 1-tuple (note the space)
+ (#,,,,#) Z5H unboxed 5-tuple
+ (NB: There is no Z1T nor Z0H.)
\begin{code}
-needs_encoding :: String -> Bool -- Needs encoding when embedded in a derived name
- -- Just look at the first character
-needs_encoding (c:cs) = not (isAlpha c || c == '_')
-
-encode_operator :: String -> String
-encode_operator nm = foldr tran "" nm
- where
- tran c cs = case trChar c of
- '\0' -> '_' : show (ord c) ++ cs -- No translation
- tr_c -> tr_c : cs
-
- trChar '&' = 'a'
- trChar '|' = 'b'
- trChar ':' = 'c'
- trChar '/' = 'd'
- trChar '=' = 'e'
- trChar '>' = 'g'
- trChar '#' = 'h'
- trChar '@' = 'i'
- trChar '<' = 'l'
- trChar '-' = 'm'
- trChar '!' = 'n'
- trChar '+' = 'p'
- trChar '\'' = 'q'
- trChar '$' = 'r'
- trChar '?' = 's'
- trChar '*' = 't'
- trChar '_' = 'u'
- trChar '.' = 'v'
- trChar '\\' = 'w'
- trChar '%' = 'x'
- trChar '~' = 'y'
- trChar '^' = 'z'
- trChar _ = '\0' -- No translation
+-- alreadyEncoded is used in ASSERTs to check for encoded
+-- strings. It isn't fail-safe, of course, because, say 'zh' might
+-- be encoded or not.
+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 ch = ISALPHANUM ch
+
+alreadyEncodedFS :: FAST_STRING -> Bool
+alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs)
+
+encode :: UserString -> EncodedString
+encode cs = case maybe_tuple cs of
+ Just n -> n -- Tuples go to Z2T etc
+ Nothing -> go cs
+ where
+ go [] = []
+ go (c:cs) = encode_ch c ++ go cs
+
+maybe_tuple "(# #)" = Just("Z1H")
+maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
+ (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H")
+ other -> Nothing
+maybe_tuple "()" = Just("Z0T")
+maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
+ (n, ')' : cs) -> Just ('Z' : shows (n+1) "T")
+ other -> Nothing
+maybe_tuple 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
+ | otherwise = _PK_ (encode str)
+ where
+ str = _UNPK_ fast_str
+
+unencodedChar :: Char -> Bool -- True for chars that don't need encoding
+unencodedChar 'Z' = False
+unencodedChar 'z' = False
+unencodedChar c = c >= 'a' && c <= 'z'
+ || c >= 'A' && c <= 'Z'
+ || c >= '0' && c <= '9'
+
+encode_ch :: Char -> EncodedString
+encode_ch c | unencodedChar c = [c] -- Common case first
+
+-- Constructors
+encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
+encode_ch ')' = "ZR" -- For symmetry with (
+encode_ch '[' = "ZM"
+encode_ch ']' = "ZN"
+encode_ch ':' = "ZC"
+encode_ch 'Z' = "ZZ"
+
+-- Variables
+encode_ch 'z' = "zz"
+encode_ch '&' = "za"
+encode_ch '|' = "zb"
+encode_ch '^' = "zc"
+encode_ch '$' = "zd"
+encode_ch '=' = "ze"
+encode_ch '>' = "zg"
+encode_ch '#' = "zh"
+encode_ch '.' = "zi"
+encode_ch '<' = "zl"
+encode_ch '-' = "zm"
+encode_ch '!' = "zn"
+encode_ch '+' = "zp"
+encode_ch '\'' = "zq"
+encode_ch '\\' = "zr"
+encode_ch '/' = "zs"
+encode_ch '*' = "zt"
+encode_ch '_' = "zu"
+encode_ch '%' = "zv"
+encode_ch c = 'z' : shows (ord c) "U"
+\end{code}
+
+Decode is used for user printing.
+
+\begin{code}
+decodeFS :: FAST_STRING -> FAST_STRING
+decodeFS fs = _PK_ (decode (_UNPK_ fs))
+
+decode :: EncodedString -> UserString
+decode [] = []
+decode ('Z' : rest) = decode_escape rest
+decode ('z' : rest) = decode_escape rest
+decode (c : rest) = c : decode rest
+
+decode_escape :: EncodedString -> UserString
+
+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
+decode_escape ('h' : rest) = '#' : decode rest
+decode_escape ('i' : rest) = '.' : decode rest
+decode_escape ('l' : rest) = '<' : decode rest
+decode_escape ('m' : rest) = '-' : decode rest
+decode_escape ('n' : rest) = '!' : decode rest
+decode_escape ('p' : rest) = '+' : decode rest
+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 ('v' : rest) = '%' : decode rest
+
+-- Tuples are coded as Z23T
+-- Characters not having a specific code are coded as z224U
+decode_escape (c : rest)
+ | isDigit c = go (digitToInt c) rest
+ where
+ go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
+ go 0 ('T' : rest) = "()" ++ (decode rest)
+ go n ('T' : rest) = '(' : replicate (n-1) ',' ++ ')' : decode rest
+ go 1 ('H' : rest) = "(# #)" ++ (decode rest)
+ go n ('H' : rest) = '(' : '#' : replicate (n-1) ',' ++ '#' : ')' : decode rest
+ go n ('U' : rest) = chr n : decode rest
+ go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest))
+
+decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest)
\end{code}
%************************************************************************
%* *
-\subsection{The 'Z' encoding}
+\subsection{Lexical categories}
%* *
%************************************************************************
-We provide two interfaces for efficiency.
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report.
\begin{code}
-identToC :: String -> FAST_STRING
-identToC str
- | all isAlphanum str && not std = _PK_ str
- | std = _PK_ ("Zs" ++ encode str)
- | otherwise = _PK_ (encode str)
- where
- std = has_std_prefix str
+isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
-identFsToC :: FAST_STRING -> FAST_STRING
-identFsToC fast_str
- | all isAlphanum str && not std = fast_str
- | std = _PK_ ("Zs" ++ encode str)
- | otherwise = _PK_ (encode str)
- where
- std = has_std_prefix str
- str = _UNPK_ fast_str
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
--- avoid "stdin", "stdout", and "stderr"...
-has_std_prefix ('s':'t':'d':_) = True
-has_std_prefix _ = False
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
-encode :: String -> String
-encode [] = []
-encode (c:cs) = encode_ch c ++ encode cs
+-------------
-encode_ch :: Char -> String
-encode_ch c | isAlphanum c = [c]
- -- Common case first
-encode_ch 'Z' = "ZZ"
-encode_ch '&' = "Za"
-encode_ch '|' = "Zb"
-encode_ch ':' = "Zc"
-encode_ch '/' = "Zd"
-encode_ch '=' = "Ze"
-encode_ch '>' = "Zg"
-encode_ch '#' = "Zh"
-encode_ch '<' = "Zl"
-encode_ch '-' = "Zm"
-encode_ch '!' = "Zn"
-encode_ch '.' = "Zs"
-encode_ch '\'' = "Zq"
-encode_ch '*' = "Zt"
-encode_ch '+' = "Zp"
-encode_ch '_' = "_"
-encode_ch c = 'Z':show (ord c)
-\end{code}
+isLexConId cs -- Prefix type or data constructors
+ | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
+ | cs == SLIT("[]") = True
+ | otherwise = startsConId (_HEAD_ cs)
-For \tr{modnameToC}, we really only have to worry about \tr{'}s
-(quote chars) in the name. Rare.
+isLexVarId cs -- Ordinary prefix identifiers
+ | _NULL_ cs = False -- e.g. "x", "_x"
+ | otherwise = startsVarId (_HEAD_ cs)
-\begin{code}
-modnameToC :: FAST_STRING -> FAST_STRING
-modnameToC fast_str = identFsToC fast_str
+isLexConSym cs -- Infix type or data constructors
+ | _NULL_ cs = False -- e.g. ":-:", ":", "->"
+ | cs == SLIT("->") = True
+ | otherwise = startsConSym (_HEAD_ cs)
+
+isLexVarSym cs -- Infix identifiers
+ | _NULL_ cs = False -- e.g. "+"
+ | 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'#
+ --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
+ --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}