module OccName (
-- Modules
Module, -- Abstract, instance of Outputable
- mkModule, mkModuleFS, moduleString, moduleCString, pprModule,
+ mkSrcModule, mkSrcModuleFS, mkSysModuleFS, mkImportModuleFS, mkBootModule, mkIfaceModuleFS,
+ moduleString, moduleUserString, moduleIfaceFlavour,
+ pprModule, pprModuleSep, pprModuleBoot,
+
+ -- IfaceFlavour
+ IfaceFlavour,
+ hiFile, hiBootFile, bootFlavour,
+
+ -- 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,
+ mkSrcOccFS, mkSysOcc, mkSysOccFS, mkSrcVarOcc, mkKindOccFS,
+ mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
+ mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
- isWildCardOcc, isAnonOcc,
- pprOccName, occNameString, occNameFlavour,
+ isTvOcc, isDataOcc, isDataSymOcc, isSymOcc,
+
+ 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,
+
+ -- 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, 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.
+
+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.
+
+These type synonyms help documentation.
+
+\begin{code}
+type UserFS = FAST_STRING -- As the user typed it
+type EncodedFS = FAST_STRING -- Encoded form
+
+type UserString = String -- As the user typed it
+type EncodedString = String -- Encoded form
+
+
+pprEncodedFS :: EncodedFS -> SDoc
+pprEncodedFS fs
+ = getPprStyle $ \ sty ->
+ if userStyle sty then
+ text (decode (_UNPK_ fs))
+ else
+ ptext fs
+\end{code}
+
%************************************************************************
%* *
-\subsection[Module]{The name of a module}
+\subsection{Interface file flavour}
%* *
%************************************************************************
+The IfaceFlavour type is used mainly in an imported Name's Provenance
+to say whether the name comes from a regular .hi file, or whether it comes
+from a hand-written .hi-boot file. This is important, because it has to be
+propagated. Suppose
+
+ C.hs imports B
+ B.hs imports A
+ A.hs imports C {-# SOURCE -#} ( f )
+
+Then in A.hi we may mention C.f, in an inlining. When compiling B we *must not*
+read C.f's details from C.hi, even if the latter happens to exist from an earlier
+compilation run. So we use the name "C!f" in A.hi, and when looking for an interface
+file with details of C!f we look in C.hi-boot. The "!" stuff is recorded in the
+IfaceFlavour in the Module of C.f in A.
+
+Not particularly beautiful, but it works.
+
\begin{code}
-data Module = Module FAST_STRING -- User and interface files
- FAST_STRING -- Print this in C files
+data IfaceFlavour = HiFile -- The thing comes from a standard interface file
+ -- or from the source file itself
+ | HiBootFile -- ... or from a handwritten "hi-boot" interface file
+ deriving( Eq )
+
+hiFile = HiFile
+hiBootFile = HiBootFile
+
+instance Text IfaceFlavour where -- Just used in debug prints of lex tokens
+ showsPrec n HiFile s = s
+ showsPrec n HiBootFile s = "!" ++ s
+
+bootFlavour :: IfaceFlavour -> Bool
+bootFlavour HiBootFile = True
+bootFlavour HiFile = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Module]{The name of a module}
+%* *
+%************************************************************************
- -- The C version has quote chars Z-encoded
+\begin{code}
+data Module = Module
+ EncodedFS
+ IfaceFlavour
+ -- Haskell module names can include the quote character ',
+ -- so the module names have the z-encoding applied to them
+\end{code}
+\begin{code}
instance Outputable Module where
ppr = pprModule
+-- Ignore the IfaceFlavour when comparing modules
instance Eq Module where
(Module m1 _) == (Module m2 _) = m1 == m2
instance Ord Module where
(Module m1 _) `compare` (Module m2 _) = m1 `compare` m2
+\end{code}
+
+\begin{code}
pprModule :: Module -> SDoc
-pprModule (Module real code)
- = getPprStyle $ \ sty ->
- if codeStyle sty then
- ptext code
- else
- ptext real
+pprModule (Module mod _) = pprEncodedFS mod
-mkModule :: String -> Module
-mkModule s = Module (_PK_ s) (identToC s)
+pprModuleSep, pprModuleBoot :: Module -> SDoc
+pprModuleSep (Module mod HiFile) = dot
+pprModuleSep (Module mod HiBootFile) = char '!'
-mkModuleFS :: FAST_STRING -> Module
-mkModuleFS s = Module s (identFsToC s)
+pprModuleBoot (Module mod HiFile) = empty
+pprModuleBoot (Module mod HiBootFile) = char '!'
+\end{code}
+
+
+\begin{code}
+mkSrcModule :: UserString -> Module
+mkSrcModule s = Module (_PK_ (encode s)) HiFile
-moduleString :: Module -> String
+mkSrcModuleFS :: UserFS -> Module
+mkSrcModuleFS s = Module (encodeFS s) HiFile
+
+mkImportModuleFS :: UserFS -> IfaceFlavour -> Module
+mkImportModuleFS s hif = Module (encodeFS s) hif
+
+mkSysModuleFS :: EncodedFS -> IfaceFlavour -> Module
+mkSysModuleFS s hif = Module s hif
+
+mkIfaceModuleFS :: EncodedFS -> Module
+mkIfaceModuleFS s = Module s HiFile
+
+mkBootModule :: Module -> Module
+mkBootModule (Module s _) = Module s HiBootFile
+
+moduleString :: Module -> EncodedString
moduleString (Module mod _) = _UNPK_ mod
-moduleCString :: Module -> String
-moduleCString (Module _ code) = _UNPK_ code
+moduleUserString :: Module -> UserString
+moduleUserString (Module mod _) = decode (_UNPK_ mod)
+
+moduleIfaceFlavour :: Module -> IfaceFlavour
+moduleIfaceFlavour (Module _ hif) = hif
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Name space}
+%* *
+%************************************************************************
+
+\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 = ASSERT( alreadyEncoded str )
+ OccName occ_sp (_PK_ str)
+
+mkSysOccFS :: NameSpace -> EncodedFS -> OccName
+mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs )
+ OccName occ_sp fs
+
+-- 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
-
-mkFsOcc :: OccSpace -> FAST_STRING -> OccName
-mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real)
+mkSrcOccFS :: NameSpace -> UserFS -> OccName
+mkSrcOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
-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:
+\begin{code}
+occNameFS :: OccName -> EncodedFS
+occNameFS (OccName _ s) = s
- _d... dictionary identifiers
+occNameString :: OccName -> EncodedString
+occNameString (OccName _ s) = _UNPK_ s
- _f... dict-fun identifiers (from inst decls)
- _g... ditto, when the tycon has symbols
+occNameUserString :: OccName -> UserString
+occNameUserString occ = decode (occNameString occ)
- _t... externally visible (non-user visible) names
+occNameSpace :: OccName -> NameSpace
+occNameSpace (OccName sp _) = sp
- _m... default methods
- _n... default methods (encoded symbols, eg. <= becomes _nle)
+setOccNameSpace :: OccName -> NameSpace -> OccName
+setOccNameSpace (OccName _ occ) sp = OccName sp occ
- _p... superclass selectors
+-- occNameFlavour is used only to generate good error messages
+occNameFlavour :: OccName -> String
+occNameFlavour (OccName sp _) = nameSpaceString sp
+\end{code}
- _v... workers
- _w... workers (encoded symbols)
+\begin{code}
+isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
- _x... local variables
+isTvOcc (OccName TvName _) = True
+isTvOcc other = False
- _u... user-defined names that previously began with '_'
+-- Data constructor operator (starts with ':', or '[]')
+-- Pretty inefficient!
+isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
+isDataSymOcc other = False
- _T... compiler-generated tycons for dictionaries
- _D.. ...ditto data cons
+isDataOcc (OccName DataName _) = True
+isDataOcc oter = False
- __.... keywords (__export, __letrec etc.)
+-- Any operator (data constructor or variable)
+-- Pretty inefficient!
+isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
+isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
+\end{code}
-This knowledge is encoded in the following functions.
+%************************************************************************
+%* *
+\subsection{Making system names}
+%* *
+%************************************************************************
+Here's our convention for splitting up the interface file name space:
+ d... dictionary identifiers
+ (local variables, so no name-clash worries)
-@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@;
- eg: workers, derived methods
+ $f... dict-fun identifiers (from inst decls)
+ $m... default methods
+ $p... superclass selectors
+ $w... workers
+ $T... compiler-generated tycons for dictionaries
+ $D... ...ditto data cons
+ $sf.. specialised version of f
-We pass a character to use as the prefix. So, for example,
- "f" gets derived to "_vf", if the prefix char is 'v'
+ in encoded form these appear as Zdfxxx etc
-\begin{code}
-mk_deriv :: OccSpace -> Char -> String -> OccName
-mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str)
-\end{code}
+ :... keywords (export:, letrec: etc.)
-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'
+This knowledge is encoded in the following functions.
+
+
+@mk_deriv@ generates an @OccName@ from the one-char prefix and a string.
+NB: The string must already be encoded!
\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
+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
+mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str)
+\end{code}
-mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc
+\begin{code}
+mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc
:: OccName -> OccName
-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
+-- These derived variables have a prefix that no Haskell value could have
+mkWorkerOcc = mk_simple_deriv varName "$w"
+mkMethodOcc = mk_simple_deriv varName "$m"
+mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
+mkClassTyConOcc = mk_simple_deriv tcName ":T" -- The : prefix makes sure it classifies
+mkClassDataConOcc = mk_simple_deriv dataName ":D" -- as a tycon/datacon
+mkDictOcc = mk_simple_deriv varName "$d"
+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}
\begin{code}
-> OccName -- Class, eg "Ord"
-> OccName -- eg "p3Ord"
mkSuperDictSelOcc index cls_occ
- = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ)
+ = mk_deriv varName "$p" (show index ++ occNameString cls_occ)
\end{code}
-> 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)
+ = mk_deriv VarName "$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
\end{code}
%************************************************************************
%* *
-\subsection{Lexical categories}
-%* *
-%************************************************************************
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
-
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
-
-isLexId cs = isLexConId cs || isLexVarId cs
-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
-
-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
-
-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}
-
-%************************************************************************
-%* *
-\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"
-
-isVarOcc, isTCOcc, isTvOcc,
- isConSymOcc, isSymOcc, isWildCardOcc :: OccName -> Bool
-
-isVarOcc (OccName VarOcc _ _ _) = True
-isVarOcc other = False
-
-isTvOcc (OccName TvOcc _ _ _) = True
-isTvOcc other = False
-
-isTCOcc (OccName TCOcc _ _ _) = True
-isTCOcc other = False
-
-isConSymOcc (OccName _ s _ _) = isLexConSym s
-
-isSymOcc (OccName _ s _ _) = isLexSym s
-
-isConOcc (OccName _ s _ _) = isLexCon s
-
-isWildCardOcc (OccName _ s _ _) = (_HEAD_ s) == '_' && _LENGTH_ s == 1
-
-isAnonOcc (OccName _ s _ _) = (_HEAD_ s) == '_'
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Comparison}
-%* *
-%************************************************************************
-
-Comparison is done by space and 'real' name
-
-\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)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Tidying them up}
%* *
%************************************************************************
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), digits, and '_'
+ 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' 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 foo_wib
+ > Zg
+ >1 Zg1
+ foo# fooZh
+ foo## fooZhZh
+ foo##1 fooZhXh1
+ fooZ fooZZ
+ :+ ZcZp
+ () Z0T
+ (,,,,) Z4T
+
\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
+ 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 cs
+maybe_tuple other = Nothing
+
+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 '_' = True
+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 '$' = "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 c = ['z', 'x', intToDigit hi, intToDigit lo]
+ where
+ (hi,lo) = ord c `quotRem` 16
+\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 ('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 ('z' : rest) = 'z' : decode rest
+decode_escape ('a' : rest) = '&' : decode rest
+decode_escape ('b' : 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 ('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}
projects / ghc-hetmet.git / blobdiff