X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=a3661a9ab0d093eba7e43ee1574dcc9a8a8c4f33;hb=c5b03909e7c630a874f6f1abf76d28baf4b19d55;hp=e52a090d7cc89dffb6288846ea0e69c61803ccb8;hpb=9aba9a7f16e3f4acd79c75aacdbaad5af92f8752;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index e52a090..a3661a9 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -7,79 +7,83 @@ \begin{code} module OccName ( - -- The NameSpace type; abstact + -- * The NameSpace type; abstact NameSpace, tcName, clsName, tcClsName, dataName, varName, - tvName, nameSpaceString, + tvName, srcDataName, - -- The OccName type + -- ** Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The OccName type OccName, -- Abstract, instance of Outputable pprOccName, - mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, - mkVarOcc, mkVarOccEncoded, - mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, - mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - mkGenOcc1, mkGenOcc2, mkLocalOcc, - - isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - reportIfUnused, - - occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkTyVarOcc, + mkDFunOcc, + mkTupleOcc, setOccNameSpace, + -- ** Derived OccNames + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, + mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, reportIfUnused, isTcClsName, isVarName, + + isTupleOcc_maybe, + + -- The OccEnv type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + 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, + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, - -- Encoding - EncodedString, EncodedFS, UserString, UserFS, encode, encodeFS, decode, pprEncodedFS, - -- The basic form of names isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - isLowerISO, isUpperISO - + startsVarSym, startsVarId, startsConSym, startsConId ) where #include "HsVersions.h" -import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) -import Util ( thenCmp ) -import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import Util ( thenCmp ) +import Unique ( Unique, mkUnique, Uniquable(..) ) +import BasicTypes ( Boxity(..), Arity ) +import StaticFlags ( opt_PprStyle_Debug ) +import UniqFM +import UniqSet import FastString import Outputable 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 +import Data.Char ( isUpper, isLower, ord ) -type UserString = String -- As the user typed it -type EncodedString = String -- Encoded form +-- Unicode TODO: put isSymbol in libcompat +#if __GLASGOW_HASKELL__ > 604 +import Data.Char ( isSymbol ) +#else +isSymbol = const False +#endif - -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} %************************************************************************ @@ -89,30 +93,68 @@ pprEncodedFS fs %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables - | DataName -- Data constructors +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 + +-- 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. + + -- 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 +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space +tvName = TvName +varName = VarName -nameSpaceString :: NameSpace -> String -nameSpaceString DataName = "Data constructor" -nameSpaceString VarName = "Variable" -nameSpaceString TvName = "Type variable" -nameSpaceString TcClsName = "Type constructor or class" +isTcClsName :: NameSpace -> Bool +isTcClsName TcClsName = True +isTcClsName _ = False + +isVarName :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarName TvName = True +isVarName VarName = True +isVarName other = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = ptext SLIT("data constructor") +pprNameSpace VarName = ptext SLIT("variable") +pprNameSpace TvName = ptext SLIT("type variable") +pprNameSpace TcClsName = ptext SLIT("type constructor or class") + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = ptext SLIT("tv") +pprNameSpaceBrief TcClsName = ptext SLIT("tc") \end{code} @@ -124,9 +166,9 @@ nameSpaceString TcClsName = "Type constructor or class" \begin{code} data OccName = OccName - NameSpace - EncodedFS - {-! derive : Binary !-} + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } \end{code} @@ -151,7 +193,13 @@ instance Outputable OccName where ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) = pprEncodedFS occ +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ftext (zEncodeFS occ) + else ftext occ <> if debugStyle sty + then braces (pprNameSpaceBrief sp) + else empty \end{code} @@ -161,77 +209,130 @@ pprOccName (OccName sp occ) = pprEncodedFS occ %* * %************************************************************************ -*Sys* things do no encoding; the caller should ensure that the thing is -already encoded - \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} +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) -*Source-code* things are encoded. +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs -\begin{code} -mkOccFS :: NameSpace -> UserFS -> OccName -mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s -mkVarOcc :: UserFS -> OccName -mkVarOcc fs = mkSysOccFS varName (encodeFS fs) +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs -mkVarOccEncoded :: EncodedFS -> OccName -mkVarOccEncoded fs = mkSysOccFS varName fs +mkTyVarOcc :: FastString -> OccName +mkTyVarOcc fs = mkOccNameFS tvName fs \end{code} - %************************************************************************ %* * -\subsection{Predicates and taking them apart} + Environments %* * %************************************************************************ -\begin{code} -occNameFS :: OccName -> EncodedFS -occNameFS (OccName _ s) = s +OccEnvs are used mainly for the envts in ModIfaces. -occNameString :: OccName -> EncodedString -occNameString (OccName _ s) = unpackFS s - -occNameUserString :: OccName -> UserString -occNameUserString occ = decode (occNameString occ) +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. -occNameSpace :: OccName -> NameSpace -occNameSpace (OccName sp _) = sp +\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 +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b + +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 +mapOccEnv = mapUFM + +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} -setOccNameSpace :: OccName -> NameSpace -> OccName -setOccNameSpace (OccName _ occ) sp = OccName sp occ --- occNameFlavour is used only to generate good error messages -occNameFlavour :: OccName -> String -occNameFlavour (OccName sp _) = nameSpaceString sp -\end{code} +%************************************************************************ +%* * +\subsection{Predicates and taking them apart} +%* * +%************************************************************************ \begin{code} -isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc other = False isTvOcc (OccName TvName _) = True isTvOcc other = False @@ -245,16 +346,29 @@ isValOcc other = False -- Data constructor operator (starts with ':', or '[]') -- Pretty inefficient! -isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc (OccName VarName s) + | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) + -- Jan06: I don't think this should happen isDataSymOcc other = False isDataOcc (OccName DataName _) = True +isDataOcc (OccName VarName s) + | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) + -- Jan06: I don't think this should happen isDataOcc other = False -- Any operator (data constructor or variable) -- Pretty inefficient! -isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) -isSymOcc (OccName VarName s) = isLexSym (decodeFS s) +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexConSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc other = False + +parenSymOcc :: OccName -> SDoc -> SDoc +-- Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc \end{code} @@ -262,13 +376,12 @@ isSymOcc (OccName VarName s) = isLexSym (decodeFS s) 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 +reportIfUnused occ = case occNameString occ of ('_' : _) -> False - zz_other -> True + _other -> True \end{code} - %************************************************************************ %* * \subsection{Making system names} @@ -302,31 +415,48 @@ NB: The string must already be encoded! \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 + -> String -> OccName -mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str) +mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) \end{code} \begin{code} -mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, + mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc :: OccName -> OccName -- 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" -- +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" -mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics -mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics + +-- 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 VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ \end{code} \begin{code} @@ -347,10 +477,23 @@ mkLocalOcc uniq occ \begin{code} -mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> OccName -- "$fOrdMaybe" - -mkDFunOcc string = mk_deriv VarName "$f" string +mkDFunOcc :: String -- Typically the class and type glommed together e.g. "OrdMaybe" + -- Only used in debug mode, for extra clarity + -> Bool -- True <=> hs-boot instance dfun + -> Int -- Unique index + -> OccName -- "$f3OrdMaybe" + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot index + = mk_deriv VarName prefix string + where + prefix | is_boot = "$fx" + | otherwise = "$f" + string | opt_PprStyle_Debug = show index ++ info_str + | otherwise = show index \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad @@ -397,222 +540,57 @@ 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 FastString 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 fs) - | not (fs `elemFM` in_scope) - = (addToFM in_scope fs 1, occ) -- First occurrence - - | otherwise -- Already occurs - = go in_scope (unpackFS fs) - 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 - - Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str) - -- str is now unique - where - pk_str = mkFastString str + = case lookupOccEnv in_scope occ of + Nothing -> -- Not already used: make it used + (extendOccEnv in_scope occ 1, occ) + + Just n -> -- Already used: make a new guess, + -- change the guess base, and try again + tidyOccName (extendOccEnv in_scope occ (n+1)) + (mkOccName occ_sp (unpackFS fs ++ show n)) \end{code} - %************************************************************************ %* * -\subsection{The 'Z' encoding} + Stuff for dealing with tuples %* * %************************************************************************ -This is the main name-encoding and decoding function. It encodes any -string into a string that is acceptable as a C name. This is the name -by which things are known right through the compiler. - -The basic encoding scheme is this. - -* Tuples (,,,) are coded as Z3T - -* Alphabetic characters (upper and lower) and digits - all translate to themselves; - except 'Z', which translates to 'ZZ' - and 'z', which translates to 'zz' - We need both so that we can preserve the variable/tycon distinction - -* Most other printable characters translate to 'zx' or 'Zx' for some - alphabetic character x - -* The others translate as 'znnnU' where 'nnn' is the decimal number - of the character - - Before After - -------------------------- - Trak Trak - foo_wib foozuwib - > zg - >1 zg1 - foo# foozh - foo## foozhzh - foo##1 foozhzh1 - fooZ fooZZ - :+ ZCzp - () Z0T 0-tuple - (,,,,) Z5T 5-tuple - (# #) Z1H unboxed 1-tuple (note the space) - (#,,,,#) Z5H unboxed 5-tuple - (NB: There is no Z1T nor Z0H.) - \begin{code} --- 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 - -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") - other -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") - other -> Nothing -maybe_tuple other = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - -encodeFS :: UserFS -> EncodedFS -encodeFS fast_str | all unencodedChar str = fast_str - | otherwise = 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' : rest) = decode_escape rest -decode ('z' : rest) = decode_escape rest -decode (c : rest) = c : decode rest - -decode_escape :: EncodedString -> UserString - -decode_escape ('L' : rest) = '(' : decode rest -decode_escape ('R' : rest) = ')' : decode rest -decode_escape ('M' : rest) = '[' : decode rest -decode_escape ('N' : rest) = ']' : decode rest -decode_escape ('C' : rest) = ':' : decode rest -decode_escape ('Z' : rest) = 'Z' : decode rest - -decode_escape ('z' : rest) = 'z' : decode rest -decode_escape ('a' : rest) = '&' : decode rest -decode_escape ('b' : rest) = '|' : decode rest -decode_escape ('c' : rest) = '^' : decode rest -decode_escape ('d' : rest) = '$' : decode rest -decode_escape ('e' : rest) = '=' : decode rest -decode_escape ('g' : rest) = '>' : decode rest -decode_escape ('h' : rest) = '#' : decode rest -decode_escape ('i' : rest) = '.' : decode rest -decode_escape ('l' : rest) = '<' : decode rest -decode_escape ('m' : rest) = '-' : decode rest -decode_escape ('n' : rest) = '!' : decode rest -decode_escape ('p' : rest) = '+' : decode rest -decode_escape ('q' : rest) = '\'' : decode rest -decode_escape ('r' : rest) = '\\' : decode rest -decode_escape ('s' : rest) = '/' : decode rest -decode_escape ('t' : rest) = '*' : decode rest -decode_escape ('u' : rest) = '_' : decode rest -decode_escape ('v' : rest) = '%' : decode rest - --- Tuples are coded as Z23T --- Characters not having a specific code are coded as z224U -decode_escape (c : rest) - | isDigit c = go (digitToInt c) rest +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc ns bx ar = OccName ns (mkFastString str) + where + -- no need to cache these, the caching is done in the caller + -- (TysWiredIn.mk_tuple) + str = case bx of + Boxed -> '(' : commas ++ ")" + Unboxed -> '(' : '#' : commas ++ "#)" + + commas = take (ar-1) (repeat ',') + +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 + '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest) + '(':',':rest -> Just (ns, Boxed, 2 + count_commas rest) + _other -> Nothing where - go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T' : rest) = "()" ++ (decode rest) - go n ('T' : rest) = '(' : replicate (n-1) ',' ++ ')' : decode rest - go 1 ('H' : rest) = "(# #)" ++ (decode rest) - go n ('H' : rest) = '(' : '#' : replicate (n-1) ',' ++ '#' : ')' : decode rest - go n ('U' : rest) = chr n : decode rest - go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest)) - -decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) -decode_escape [] = pprTrace "decode_escape" (text "empty") "" + count_commas (',':rest) = 1 + count_commas rest + count_commas _ = 0 \end{code} - %************************************************************************ %* * \subsection{Lexical categories} @@ -635,40 +613,41 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors - | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" | cs == FSLIT("[]") = True | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers - | nullFastString cs = False -- e.g. "x", "_x" + | nullFS cs = False -- e.g. "x", "_x" | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors - | nullFastString cs = False -- e.g. ":-:", ":", "->" + | nullFS cs = False -- e.g. ":-:", ":", "->" | cs == FSLIT("->") = True | otherwise = startsConSym (headFS cs) isLexVarSym cs -- Infix identifiers - | nullFastString cs = False -- e.g. "+" + | nullFS cs = False -- e.g. "+" | otherwise = startsVarSym (headFS cs) ------------- startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool -startsVarSym c = isSymbolASCII c || isSymbolISO c -- Infix Ids +startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol 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 - +startsVarId c = isLower c || c == '_' -- Ordinary Ids +startsConId c = isUpper 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} + +%************************************************************************ +%* * + Binary instance + Here rather than BinIface because OccName is abstract +%* * +%************************************************************************ + \begin{code} -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} instance Binary NameSpace where put_ bh VarName = do putByte bh 0 @@ -694,7 +673,4 @@ instance Binary OccName where aa <- get bh ab <- get bh return (OccName aa ab) - --- Imported from other files :- - \end{code}