\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, ipName,
+ tvName, uvName, 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,
+ mkSrcOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkSrcVarOcc, mkKindOccFS,
+ mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
+ mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
+ mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
- isWildCardOcc, isAnonOcc,
- pprOccName, occNameString, occNameFlavour,
+ isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, 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"
-#if __HASKELL1__ > 4
-import Char ( isAlpha, isUpper, isLower, isAlphaNum{-sigh-}, ord )
-#else
-import Char ( isAlpha, isUpper, isLower, isAlphanum, ord )
-#endif
+import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt, intToDigit )
import Util ( thenCmp )
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}
-%* *
-%************************************************************************
-
-\begin{code}
-data Module = Module FAST_STRING -- User and interface files
- FAST_STRING -- Print this in C files
+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.
- -- 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
+ if userStyle sty then
+ text (decode (_UNPK_ fs))
else
- ptext real
-
-mkModule :: String -> Module
-mkModule s = Module (_PK_ s) (identToC s)
-
-mkModuleFS :: FAST_STRING -> Module
-mkModuleFS s = Module s (identFsToC s)
+ 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
+ | 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 )
+
+-- 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
+uvName = UvName
+varName = VarName
+ipName = IPName
+
+
+nameSpaceString :: NameSpace -> String
+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}
%************************************************************************
\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
- '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str)
- where
- zapped_str = '_' : 'u' : rest
-
- other -> OccName occ_sp real real (identFsToC real)
+*Sys* things do no encoding; the caller should ensure that the thing is
+already encoded
-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
+
+mkCCallOcc :: 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!
+mkCCallOcc str = OccName varName (_PK_ str)
+
+-- Kind constructors get a speical 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
+mkSrcOccFS :: NameSpace -> UserFS -> OccName
+mkSrcOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
-mkFsOcc :: OccSpace -> FAST_STRING -> OccName
-mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real)
-
-varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName
-varOcc = mkFsOcc VarOcc
-tcOcc = mkFsOcc TCOcc
-tvOcc = mkFsOcc TvOcc
+mkSrcVarOcc :: UserFS -> OccName
+mkSrcVarOcc 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, isUvOcc :: OccName -> Bool
+isTvOcc (OccName TvName _) = True
+isTvOcc other = False
-mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc
- :: OccName -> OccName
+isUvOcc (OccName UvName _) = True
+isUvOcc 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)
+
+isIPOcc (OccName IPName _) = True
+isIPOcc _ = False
\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.)
-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 one-char 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 itempotent
+ -> 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
-
--- 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"
+\begin{code}
+mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc
+ :: OccName -> OccName
-isVarOcc, isTCOcc, isTvOcc,
- isConSymOcc, isSymOcc, isWildCardOcc :: OccName -> Bool
+-- 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"
+
+mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
+\end{code}
-isVarOcc (OccName VarOcc _ _ _) = True
-isVarOcc other = False
+\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)
+\end{code}
-isTvOcc (OccName TvOcc _ _ _) = True
-isTvOcc other = False
-isTCOcc (OccName TCOcc _ _ _) = True
-isTCOcc other = False
+\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
-isConSymOcc (OccName _ s _ _) = isLexConSym s
+ -> OccName -- "$fOrdMaybe3"
-isSymOcc (OccName _ s _ _) = isLexSym s
+mkDFunOcc string index
+ = mk_deriv VarName "$f" (show_index ++ string)
+ where
+ show_index | index == 0 = ""
+ | otherwise = show index
+\end{code}
-isConOcc (OccName _ s _ _) = isLexCon 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)
-isWildCardOcc (OccName _ s _ _) = (_HEAD_ s) == '_' && _LENGTH_ s == 1
+The way it is now, -ddump-xx output may look confusing, but
+you can always say -dppr-debug to get the uniques.
-isAnonOcc (OccName _ s _ _) = (_HEAD_ 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 'zxdd' where 'dd' is exactly two hexadecimal
+ digits for the ord of the character
+
+ Before After
+ --------------------------
+ Trak Trak
+ foo_wib foozuwib
+ > zg
+ >1 zg1
+ foo# foozh
+ foo## foozhzh
+ foo##1 foozhzh1
+ fooZ fooZZ
+ :+ Zczp
+ () Z0T
+ (,,,,) Z4T
+
+
+\begin{code}
+-- 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 -> 'Z' : show n ++ "T" -- 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
+
+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
+
+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 = ISALPHANUM c
+
+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', 'x', intToDigit hi, intToDigit lo]
+ where
+ (hi,lo) = ord c `quotRem` 16
+\end{code}
+
+Decode is used for user printing.
\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
+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
+decode_escape ('x' : d1 : d2 : rest) = chr (digitToInt d1 * 16 + digitToInt d2) : decode rest
+
+-- Tuples are coded as Z23T
+decode_escape (c : rest)
+ | isDigit c = go (digitToInt 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 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}
+n\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
+ | c == '(' = True -- (), (,), (,,), ...
+ | otherwise = isUpper c || isUpperISO c
+ where
+ c = _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 = isLower c || isLowerISO c || c == '_'
+ where
+ c = _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. ":-:", ":", "->"
+ | otherwise = c == ':'
+ || cs == SLIT("->")
+ where
+ c = _HEAD_ cs
+
+isLexVarSym cs -- Infix identifiers
+ | _NULL_ cs = False -- e.g. "+"
+ | otherwise = isSymbolASCII c
+ || isSymbolISO c
+ where
+ c = _HEAD_ cs
+
+-------------
+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}