X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=29a6bbc2fb3ba77ea140f9d9b574ff1caf5d1f5c;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=ede2a97f9c41f123cdf0b345f80fa46d8fc59960;hpb=ffb05ba37449e9717300101dfc45480a098c753b;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index ede2a97..29a6bbc 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -1,4 +1,5 @@ - +{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -6,92 +7,149 @@ \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, srcDataName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable - varOcc, tcOcc, tvOcc, -- Occ constructors - srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code - - mkSuperDictSelOcc, mkDFunOcc, - mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkClassTyConOcc, mkClassDataConOcc, + pprOccName, + + -- The OccEnv type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + + + -- The OccSet type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, + foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + + mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, + mkVarOcc, mkVarOccEncoded, + mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, + mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, + mkGenOcc1, mkGenOcc2, mkLocalOcc, mkDataTOcc, mkDataCOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, - isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc, - isWildCardOcc, isAnonOcc, - pprOccName, occNameString, occNameFlavour, + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, reportIfUnused, + + occNameFS, occNameString, occNameUserString, occNameSpace, + occNameFlavour, briefOccNameFlavour, + setOccNameSpace, + + mkTupleOcc, isTupleOcc_maybe, - -- 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 -#define ISALPHANUM isAlphaNum -#else -#define ISALPHANUM isAlphanum -#endif - -import Char ( isAlpha, isUpper, isLower, ISALPHANUM, ord ) +import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import Unique ( Unique, mkUnique, Uniquable(..) ) +import BasicTypes ( Boxity(..), Arity ) +import UniqFM +import UniqSet +import FastString import Outputable -import GlaExts +import Binary + +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 = FastString -- As the user typed it +type EncodedFS = FastString -- 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 + -- ftext (decodeFS fs) would needlessly pack the string again + then text (decode (unpackFS fs)) + else ftext fs +\end{code} %************************************************************************ %* * -\subsection[Module]{The name of a module} +\subsection{Name space} %* * %************************************************************************ \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 - -instance Outputable Module where - ppr = pprModule +data NameSpace = VarName -- Variables, including "source" data constructors + | DataName -- "Real" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + {-! derive: Binary !-} + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in DataCon.lhs +-- +-- "Source" data constructors are the data constructors mentioned +-- in Haskell source code +-- +-- "Real" data constructors are the data constructors of the +-- representation type, which may not be the same as the source +-- type -instance Eq Module where - (Module m1 _) == (Module m2 _) = m1 == m2 +-- Example: +-- data T = T !(Int,Int) +-- +-- The source datacon has type (Int,Int) -> T +-- The real datacon has type Int -> Int -> T +-- GHC chooses a representation based on the strictness etc. -instance Ord Module where - (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 -pprModule :: Module -> SDoc -pprModule (Module real code) - = getPprStyle $ \ sty -> - if codeStyle sty then - ptext code - else - ptext real +-- 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! -mkModule :: String -> Module -mkModule s = Module (_PK_ s) (identToC s) +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space -mkModuleFS :: FAST_STRING -> Module -mkModuleFS s = Module s (identFsToC s) +tvName = TvName +varName = VarName -moduleString :: Module -> String -moduleString (Module mod _) = _UNPK_ mod - -moduleCString :: Module -> String -moduleCString (Module _ code) = _UNPK_ code +nameSpaceString :: NameSpace -> String +nameSpaceString DataName = "Data constructor" +nameSpaceString VarName = "Variable" +nameSpaceString TvName = "Type variable" +nameSpaceString TcClsName = "Type constructor or class" \end{code} @@ -102,44 +160,20 @@ moduleCString (Module _ code) = _UNPK_ 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 OccName = OccName + NameSpace + EncodedFS + {-! derive : Binary !-} +\end{code} -data OccSpace = VarOcc -- Variables and data constructors - | TvOcc -- Type variables - | TCOcc -- Type constructors and classes - deriving( Eq, Ord ) +\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} @@ -151,17 +185,14 @@ data OccSpace = VarOcc -- Variables and data constructors \begin{code} instance Outputable OccName where - ppr = pprOccName + ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName space real iface code) +pprOccName (OccName sp occ) = getPprStyle $ \ sty -> - if codeStyle sty then - ptext code - else if ifaceStyle sty then - ptext iface - else - ptext real + pprEncodedFS occ <> if debugStyle sty then + braces (text (briefNameSpaceFlavour sp)) + else empty \end{code} @@ -169,278 +200,355 @@ pprOccName (OccName space real iface 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 +%*****p******************************************************************* - '_' : 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 (mkFastString 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 (mkFastString 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 +mkOccFS :: NameSpace -> UserFS -> OccName +mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) + +mkOccName :: NameSpace -> String -> OccName +mkOccName ns s = mkSysOcc ns (encode s) -mkFsOcc :: OccSpace -> FAST_STRING -> OccName -mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real) +mkVarOcc :: UserFS -> OccName +mkVarOcc fs = mkSysOccFS varName (encodeFS fs) -varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName -varOcc = mkFsOcc VarOcc -tcOcc = mkFsOcc TCOcc -tvOcc = mkFsOcc TvOcc +mkVarOccEncoded :: EncodedFS -> OccName +mkVarOccEncoded fs = mkSysOccFS varName fs \end{code} + %************************************************************************ %* * -\subsection{Making system names} + Environments %* * %************************************************************************ -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 +OccEnvs are used mainly for the envts in ModIfaces. - _v... workers - _w... workers (encoded symbols) +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, so we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char reprsenting the name space. This in turn makes it +easy to build an OccEnv. - _x... local variables +\begin{code} +instance Uniquable OccName where + getUnique (OccName ns fs) + = mkUnique char (I# (uniqueOfFS fs)) + where -- See notes above about this getUnique function + char = case ns of + VarName -> 'i' + DataName -> 'd' + TvName -> 'v' + TcClsName -> 't' + +type OccEnv a = UniqFM a + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a + +emptyOccEnv = emptyUFM +unitOccEnv = unitUFM +extendOccEnv = addToUFM +extendOccEnvList = addListToUFM +lookupOccEnv = lookupUFM +mkOccEnv = listToUFM +elemOccEnv = elemUFM +foldOccEnv = foldUFM +occEnvElts = eltsUFM +plusOccEnv = plusUFM +plusOccEnv_C = plusUFM_C +extendOccEnv_C = addToUFM_C + + +type OccSet = UniqFM OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +occSetElts :: OccSet -> [OccName] +foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +occSetElts = uniqSetToList +foldOccSet = foldUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +\end{code} - _u... user-defined names that previously began with '_' - _T... compiler-generated tycons for dictionaries - _D.. ...ditto data cons +%************************************************************************ +%* * +\subsection{Predicates and taking them apart} +%* * +%************************************************************************ - __.... keywords (__export, __letrec etc.) +\begin{code} +occNameFS :: OccName -> EncodedFS +occNameFS (OccName _ s) = s -This knowledge is encoded in the following functions. +occNameString :: OccName -> EncodedString +occNameString (OccName _ s) = unpackFS s +occNameUserString :: OccName -> UserString +occNameUserString occ = decode (occNameString occ) +occNameSpace :: OccName -> NameSpace +occNameSpace (OccName sp _) = sp +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ -@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@; - eg: workers, derived methods +-- occNameFlavour is used only to generate good error messages +occNameFlavour :: OccName -> SDoc +occNameFlavour (OccName DataName _) = ptext SLIT("data constructor") +occNameFlavour (OccName TvName _) = ptext SLIT("type variable") +occNameFlavour (OccName TcClsName _) = ptext SLIT("type constructor or class") +occNameFlavour (OccName VarName s) = empty -We pass a character to use as the prefix. So, for example, - "f" gets derived to "_vf", if the prefix char is 'v' +-- briefOccNameFlavour is used in debug-printing of names +briefOccNameFlavour :: OccName -> String +briefOccNameFlavour (OccName sp _) = briefNameSpaceFlavour sp -\begin{code} -mk_deriv :: OccSpace -> Char -> String -> OccName -mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str) +briefNameSpaceFlavour DataName = "d" +briefNameSpaceFlavour VarName = "v" +briefNameSpaceFlavour TvName = "tv" +briefNameSpaceFlavour TcClsName = "tc" \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 - - -mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkClassTyConOcc, mkClassDataConOcc - :: 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 -\end{code} - -\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) +isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc other = False + +isTvOcc (OccName TvName _) = True +isTvOcc other = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc other = False + +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc other = False + +-- Data constructor operator (starts with ':', or '[]') +-- Pretty inefficient! +isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isDataSymOcc (OccName VarName s) = isLexConSym (decodeFS s) +isDataSymOcc other = False + +isDataOcc (OccName DataName _) = True +isDataOcc (OccName VarName s) = isLexCon (decodeFS s) +isDataOcc other = False + +-- Any operator (data constructor or variable) +-- Pretty inefficient! +isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isSymOcc (OccName TcClsName s) = isLexConSym (decodeFS s) +isSymOcc (OccName VarName s) = isLexSym (decodeFS s) +isSymOcc other = False + +parenSymOcc :: OccName -> SDoc -> SDoc +-- Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc \end{code} \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 +reportIfUnused :: OccName -> Bool + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". +reportIfUnused occ = case occNameUserString occ of + ('_' : _) -> False + zz_other -> True \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 - --- 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 +\begin{code} +mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc + :: OccName -> OccName -isVarOcc (OccName VarOcc _ _ _) = True -isVarOcc other = False +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +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" -- We go straight to the "real" data con + -- for datacons from classes +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" + +-- Generic derivable classes +mkGenOcc1 = mk_simple_deriv varName "$gfrom" +mkGenOcc2 = mk_simple_deriv varName "$gto" + +-- data T = MkT ... deriving( Data ) needs defintions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc = mk_simple_deriv varName "$t" +mkDataCOcc = mk_simple_deriv varName "$c" + +mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) + + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to DataName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ +\end{code} -isTvOcc (OccName TvOcc _ _ _) = True -isTvOcc 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) + +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} -isTCOcc (OccName TCOcc _ _ _) = True -isTCOcc other = False -isConSymOcc (OccName _ s _ _) = isLexConSym s +\begin{code} +mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" + -> OccName -- "$fOrdMaybe" -isSymOcc (OccName _ s _ _) = isLexSym s +mkDFunOcc string = mk_deriv VarName "$f" string +\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} @@ -462,148 +570,354 @@ because that isn't a single lexeme. So we encode it to 'lle' and *then* tack on the '1', if necessary. \begin{code} -type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames -emptyTidyOccEnv = emptyFM +type TidyOccEnv = OccEnv Int -- The in-scope OccNames + -- Range gives a plausible starting point for new guesses + +emptyTidyOccEnv = emptyOccEnv initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv +initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 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. +tidyOccName in_scope occ@(OccName occ_sp fs) + = case lookupOccEnv in_scope occ of + Nothing -> -- Not already used: make it used + (extendOccEnv in_scope occ 1, occ) - = (addToFM in_scope real 1, occ) -- First occurrence + Just n -> -- Already used: make a new guess, + -- change the guess base, and try again + tidyOccName (extendOccEnv in_scope occ (n+1)) + (mkSysOcc occ_sp (unpackFS fs ++ show n)) +\end{code} - | 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)) - where - go in_scope str = case lookupFM in_scope pk_str of - Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n) - -- Need to go round again, just in case "t3" (say) - -- clashes with a "t3" that's already in scope +%************************************************************************ +%* * +\subsection{The 'Z' encoding} +%* * +%************************************************************************ + +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.) - Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str) - -- str is now unique - where - pk_str = _PK_ str +\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 :: FastString -> Bool +alreadyEncodedFS fs = alreadyEncoded (unpackFS 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 + +encodeFS :: UserFS -> EncodedFS +encodeFS fast_str | all unencodedChar str = fast_str + | otherwise = mkFastString (encode str) + where + str = unpackFS 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 :: FastString -> FastString +decodeFS fs = mkFastString (decode (unpackFS fs)) + +decode :: EncodedString -> UserString +decode [] = [] +decode ('Z' : d : rest) | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : decode rest +decode ('z' : d : rest) | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : decode rest +decode (c : rest) = c : decode rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = pprTrace "decode_upper" (char ch) ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = pprTrace "decode_lower" (char ch) ch + +-- Characters not having a specific code are coded as z224U +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go n ('U' : rest) = chr n : decode rest + go n other = pprPanic "decode_num_esc" (ppr n <+> text other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to decode after decoding the tuple, because + -- the tuple might be embedded in a longer name. + 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 other = pprPanic "decode_tuple" (ppr n <+> text other) \end{code} %************************************************************************ %* * -\subsection{Encoding for operators in derived names} + Stuff for dealing with tuples %* * %************************************************************************ -See comments with mk_enc_deriv +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. + \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 +maybe_tuple :: UserString -> Maybe EncodedString + +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) \end{code} +\begin{code} +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc ns bx ar + = OccName ns (mkFastString ('Z' : (show ar ++ bx_char))) + where + bx_char = case bx of + Boxed -> "T" + Unboxed -> "H" + +isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) +-- Tuples are special, because there are so many of them! +isTupleOcc_maybe (OccName ns fs) + = case unpackFS fs of + ('Z':d:rest) | isDigit d -> Just (decode_tup (digitToInt d) rest) + other -> Nothing + where + decode_tup n "H" = (ns, Unboxed, n) + decode_tup n "T" = (ns, Boxed, n) + decode_tup n (d:rest) = decode_tup (n*10 + digitToInt d) 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 :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> 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) +isLexConId cs -- Prefix type or data constructors + | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" + | cs == FSLIT("[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFastString cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFastString cs = False -- e.g. ":-:", ":", "->" + | cs == FSLIT("->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym cs -- Infix identifiers + | nullFastString cs = False -- e.g. "+" + | otherwise = startsVarSym (headFS 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} -For \tr{modnameToC}, we really only have to worry about \tr{'}s -(quote chars) in the name. Rare. +%************************************************************************ +%* * + Binary instance + Here rather than BinIface because OccName is abstract +%* * +%************************************************************************ \begin{code} -modnameToC :: FAST_STRING -> FAST_STRING -modnameToC fast_str = identFsToC fast_str +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) \end{code}