X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=29a6bbc2fb3ba77ea140f9d9b574ff1caf5d1f5c;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=76cbbb06c50c322afe3fda619835f2861f5d9c3d;hpb=3c1b89ab88b2f349a698e9eb05d0e971a670f245;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 76cbbb0..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 % @@ -7,23 +8,41 @@ \begin{code} module OccName ( -- The NameSpace type; abstact - NameSpace, tcName, clsName, tcClsName, dataName, varName, ipName, - tvName, uvName, nameSpaceString, + NameSpace, tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable pprOccName, - mkSrcOccFS, mkSysOcc, mkSysOccFS, mkCCallOcc, mkSrcVarOcc, mkKindOccFS, + -- 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, - isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, reportIfUnused, - occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, + occNameFS, occNameString, occNameUserString, occNameSpace, + occNameFlavour, briefOccNameFlavour, setOccNameSpace, + mkTupleOcc, isTupleOcc_maybe, + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -39,11 +58,17 @@ module OccName ( #include "HsVersions.h" -import Char ( isDigit, isAlpha, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt, intToDigit ) +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 @@ -58,15 +83,20 @@ 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 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 = ptext fs +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} %************************************************************************ @@ -76,14 +106,31 @@ pprEncodedFS fs = ptext fs %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables - | IPName -- Implicit Parameters - | DataName -- Data constructors +data NameSpace = VarName -- Variables, including "source" data constructors + | DataName -- "Real" data constructors | TvName -- Type variables - | UvName -- Usage variables | TcClsName -- Type constructors and classes; Haskell has them -- in the same name space for now. deriving( Eq, Ord ) + {-! 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 @@ -91,19 +138,17 @@ tcName = TcClsName -- Type constructors clsName = TcClsName -- Classes tcClsName = TcClsName -- Not sure which! -dataName = DataName -tvName = TvName -uvName = UvName -varName = VarName -ipName = IPName +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 IPName = "Implicit Param" nameSpaceString TvName = "Type variable" -nameSpaceString UvName = "Usage variable" nameSpaceString TcClsName = "Type constructor or class" \end{code} @@ -118,6 +163,7 @@ nameSpaceString TcClsName = "Type constructor or class" data OccName = OccName NameSpace EncodedFS + {-! derive : Binary !-} \end{code} @@ -142,7 +188,11 @@ instance Outputable OccName where ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) = pprEncodedFS occ +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + pprEncodedFS occ <> if debugStyle sty then + braces (text (briefNameSpaceFlavour sp)) + else empty \end{code} @@ -150,7 +200,7 @@ pprOccName (OccName sp occ) = pprEncodedFS occ %* * \subsection{Construction} %* * -%************************************************************************ +%*****p******************************************************************* *Sys* things do no encoding; the caller should ensure that the thing is already encoded @@ -158,20 +208,20 @@ already encoded \begin{code} mkSysOcc :: NameSpace -> EncodedString -> OccName mkSysOcc occ_sp str = ASSERT2( alreadyEncoded str, text str ) - OccName occ_sp (_PK_ str) + OccName occ_sp (mkFastString str) mkSysOccFS :: NameSpace -> EncodedFS -> OccName mkSysOccFS occ_sp fs = ASSERT2( alreadyEncodedFS fs, ppr fs ) OccName occ_sp fs -mkCCallOcc :: EncodedString -> OccName +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! -mkCCallOcc str = OccName varName (_PK_ str) +mkFCallOcc str = OccName varName (mkFastString str) --- Kind constructors get a speical function. Uniquely, they are not encoded, +-- 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. @@ -182,17 +232,111 @@ mkKindOccFS occ_sp fs = OccName occ_sp fs *Source-code* things are encoded. \begin{code} -mkSrcOccFS :: NameSpace -> UserFS -> OccName -mkSrcOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) +mkOccFS :: NameSpace -> UserFS -> OccName +mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs) -mkSrcVarOcc :: UserFS -> OccName -mkSrcVarOcc fs = mkSysOccFS varName (encodeFS fs) +mkOccName :: NameSpace -> String -> OccName +mkOccName ns s = mkSysOcc ns (encode s) + +mkVarOcc :: UserFS -> OccName +mkVarOcc fs = mkSysOccFS varName (encodeFS fs) + +mkVarOccEncoded :: EncodedFS -> OccName +mkVarOccEncoded fs = mkSysOccFS varName fs \end{code} %************************************************************************ %* * + Environments +%* * +%************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +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. + +\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} + + +%************************************************************************ +%* * \subsection{Predicates and taking them apart} %* * %************************************************************************ @@ -202,7 +346,7 @@ occNameFS :: OccName -> EncodedFS occNameFS (OccName _ s) = s occNameString :: OccName -> EncodedString -occNameString (OccName _ s) = _UNPK_ s +occNameString (OccName _ s) = unpackFS s occNameUserString :: OccName -> UserString occNameUserString occ = decode (occNameString occ) @@ -210,22 +354,37 @@ occNameUserString occ = decode (occNameString occ) occNameSpace :: OccName -> NameSpace occNameSpace (OccName sp _) = sp -setOccNameSpace :: OccName -> NameSpace -> OccName -setOccNameSpace (OccName _ occ) sp = OccName sp occ +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ -- occNameFlavour is used only to generate good error messages -occNameFlavour :: OccName -> String -occNameFlavour (OccName sp _) = nameSpaceString sp +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 + +-- briefOccNameFlavour is used in debug-printing of names +briefOccNameFlavour :: OccName -> String +briefOccNameFlavour (OccName sp _) = briefNameSpaceFlavour sp + +briefNameSpaceFlavour DataName = "d" +briefNameSpaceFlavour VarName = "v" +briefNameSpaceFlavour TvName = "tv" +briefNameSpaceFlavour TcClsName = "tc" \end{code} \begin{code} -isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool +isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc other = False isTvOcc (OccName TvName _) = True isTvOcc other = False -isUvOcc (OccName UvName _) = True -isUvOcc other = False +isTcOcc (OccName TcClsName _) = True +isTcOcc other = False isValOcc (OccName VarName _) = True isValOcc (OccName DataName _) = True @@ -234,21 +393,38 @@ 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 VarName s) = isLexSym (decodeFS s) +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} + -isIPOcc (OccName IPName _) = True -isIPOcc _ = False +\begin{code} +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{Making system names} @@ -264,25 +440,26 @@ Here's our convention for splitting up the interface file name space: $dm... default methods $p... superclass selectors $w... workers - $T... compiler-generated tycons for dictionaries - $D... ...ditto data cons + :T... compiler-generated tycons for dictionaries + :D... ...ditto data cons $sf.. specialised version of f in encoded form these appear as Zdfxxx etc :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! This knowledge is encoded in the following functions. -@mk_deriv@ generates an @OccName@ from the one-char prefix and a string. +@mk_deriv@ generates an @OccName@ from the prefix and a string. 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 itempotent + -- second time because encoding isn't idempotent -> OccName mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str) @@ -294,48 +471,59 @@ mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have -mkWorkerOcc = mk_simple_deriv varName "$w" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies -mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon -mkClassDataConOcc = mk_simple_deriv dataName ":D" -- -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" +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) -isSysOcc :: OccName -> Bool -- True for all these '$' things -isSysOcc occ = case occNameUserString occ of - ('$' : _ ) -> True - other -> False -- We don't care about the ':' ones - -- isSysOcc is only called for Ids anyway +-- 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} \begin{code} mkSuperDictSelOcc :: Int -- Index of superclass, eg 3 -> OccName -- Class, eg "Ord" - -> OccName -- eg "p3Ord" + -> 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} \begin{code} mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> Int -- Unique to distinguish dfuns which share the previous two - -- eg 3 - -- The requirement is that the (string,index) pair be unique in this module - - -> OccName -- "$fOrdMaybe3" + -> OccName -- "$fOrdMaybe" -mkDFunOcc string index - = mk_deriv VarName "$f" (show_index ++ string) - where - show_index | index == 0 = "" - | otherwise = show index +mkDFunOcc string = mk_deriv VarName "$f" string \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad @@ -382,31 +570,25 @@ 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 fs) - | not (fs `elemFM` in_scope) - = (addToFM in_scope fs 1, occ) -- First occurrence - - | otherwise -- Already occurs - = go in_scope (_UNPK_ 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 = _PK_ 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)) + (mkSysOcc occ_sp (unpackFS fs ++ show n)) \end{code} @@ -433,8 +615,8 @@ The basic encoding scheme is this. * Most other printable characters translate to 'zx' or 'Zx' for some alphabetic character x -* The others translate as 'zxdd' where 'dd' is exactly two hexadecimal - digits for the ord of the character +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character Before After -------------------------- @@ -446,10 +628,12 @@ The basic encoding scheme is this. foo## foozhzh foo##1 foozhzh1 fooZ fooZZ - :+ Zczp - () Z0T - (,,,,) Z4T - + :+ 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 @@ -458,42 +642,36 @@ The basic encoding scheme is this. 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 + ok ' ' = True + -- This is a bit of a lie; if we really wanted spaces + -- in names we'd have to encode them. But we do put + -- spaces in ccall "occurrences", and we don't want to + -- reject them here + ok ch = isAlphaNum ch -alreadyEncodedFS :: FAST_STRING -> Bool -alreadyEncodedFS fs = alreadyEncoded (_UNPK_ fs) +alreadyEncodedFS :: FastString -> Bool +alreadyEncodedFS fs = alreadyEncoded (unpackFS fs) encode :: UserString -> EncodedString encode cs = case maybe_tuple cs of - Just n -> 'Z' : show n ++ "T" -- Tuples go to Z2T etc + Just n -> n -- Tuples go to Z2T etc Nothing -> go cs where go [] = [] go (c:cs) = encode_ch c ++ go cs --- ToDo: Unboxed tuples too, perhaps? -maybe_tuple ('(' : cs) = check_tuple (0::Int) cs -maybe_tuple other = Nothing - -check_tuple :: Int -> String -> Maybe Int -check_tuple n (',' : cs) = check_tuple (n+1) cs -check_tuple n ")" = Just n -check_tuple n other = Nothing - encodeFS :: UserFS -> EncodedFS encodeFS fast_str | all unencodedChar str = fast_str - | otherwise = _PK_ (encode str) + | otherwise = mkFastString (encode str) where - str = _UNPK_ fast_str + str = unpackFS fast_str unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False unencodedChar 'z' = False -unencodedChar c = ISALPHANUM c +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 @@ -526,68 +704,137 @@ encode_ch '/' = "zs" encode_ch '*' = "zt" encode_ch '_' = "zu" encode_ch '%' = "zv" -encode_ch c = ['z', 'x', intToDigit hi, intToDigit lo] - where - (hi,lo) = ord c `quotRem` 16 +encode_ch c = 'z' : shows (ord c) "U" \end{code} Decode is used for user printing. \begin{code} -decodeFS :: FAST_STRING -> FAST_STRING -decodeFS fs = _PK_ (decode (_UNPK_ fs)) +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 ('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_escape :: EncodedString -> UserString - -decode_escape ('L' : rest) = '(' : decode rest -decode_escape ('R' : rest) = ')' : decode rest -decode_escape ('M' : rest) = '[' : decode rest -decode_escape ('N' : rest) = ']' : decode rest -decode_escape ('C' : rest) = ':' : decode rest -decode_escape ('Z' : rest) = 'Z' : decode rest - -decode_escape ('z' : rest) = 'z' : decode rest -decode_escape ('a' : rest) = '&' : decode rest -decode_escape ('b' : rest) = '|' : decode rest -decode_escape ('c' : rest) = '^' : decode rest -decode_escape ('d' : rest) = '$' : decode rest -decode_escape ('e' : rest) = '=' : decode rest -decode_escape ('g' : rest) = '>' : decode rest -decode_escape ('h' : rest) = '#' : decode rest -decode_escape ('i' : rest) = '.' : decode rest -decode_escape ('l' : rest) = '<' : decode rest -decode_escape ('m' : rest) = '-' : decode rest -decode_escape ('n' : rest) = '!' : decode rest -decode_escape ('p' : rest) = '+' : decode rest -decode_escape ('q' : rest) = '\'' : decode rest -decode_escape ('r' : rest) = '\\' : decode rest -decode_escape ('s' : rest) = '/' : decode rest -decode_escape ('t' : rest) = '*' : decode rest -decode_escape ('u' : rest) = '_' : decode rest -decode_escape ('v' : rest) = '%' : decode rest -decode_escape ('x' : d1 : d2 : rest) = chr (digitToInt d1 * 16 + digitToInt d2) : decode rest - --- Tuples are coded as Z23T -decode_escape (c : rest) - | isDigit c = go (digitToInt c) rest +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 n ('T' : rest) = '(' : replicate n ',' ++ ')' : decode rest - go n other = pprPanic "decode_escape" (ppr n <+> text (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} + + +%************************************************************************ +%* * + Stuff for dealing with tuples +%* * +%************************************************************************ + +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z -decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) +* "(# #)" 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} +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} %************************************************************************ %* * -n\subsection{Lexical categories} +\subsection{Lexical categories} %* * %************************************************************************ @@ -595,8 +842,8 @@ 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, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool isLexCon cs = isLexConId cs || isLexConSym cs isLexVar cs = isLexVarId cs || isLexVarSym cs @@ -607,22 +854,22 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors - | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)" - | cs == SLIT("[]") = True - | otherwise = startsConId (_HEAD_ cs) + | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" + | cs == FSLIT("[]") = True + | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers - | _NULL_ cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (_HEAD_ cs) + | nullFastString cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors - | _NULL_ cs = False -- e.g. ":-:", ":", "->" - | cs == SLIT("->") = True - | otherwise = startsConSym (_HEAD_ cs) + | nullFastString cs = False -- e.g. ":-:", ":", "->" + | cs == FSLIT("->") = True + | otherwise = startsConSym (headFS cs) isLexVarSym cs -- Infix identifiers - | _NULL_ cs = False -- e.g. "+" - | otherwise = startsVarSym (_HEAD_ cs) + | nullFastString cs = False -- e.g. "+" + | otherwise = startsVarSym (headFS cs) ------------- startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool @@ -639,3 +886,38 @@ isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neCh 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} +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}