X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=756d6a955a7d9f9068fad4152bdcaf29d1eaea32;hb=10dd2a6d050e4779782800184014b8738fadc679;hp=50b39fe7f004ab95d866f4e24f01c61a884dac03;hpb=0e2c58247410a9317064bbddbf294644c0300b14;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 50b39fe..756d6a9 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -27,7 +27,7 @@ module OccName ( foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, - mkVarOcc, mkVarOccEncoded, + mkVarOcc, mkVarOccEncoded, mkTyVarOcc, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, @@ -35,7 +35,7 @@ module OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - reportIfUnused, + parenSymOcc, reportIfUnused, isTcClsName, isVarName, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, briefOccNameFlavour, @@ -52,8 +52,8 @@ module OccName ( -- The basic form of names isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - isLowerISO, isUpperISO - + isLowerISO, isUpperISO, + startsVarSym, startsVarId, startsConSym, startsConId ) where #include "HsVersions.h" @@ -62,6 +62,7 @@ import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) import Unique ( Unique, mkUnique, Uniquable(..) ) import BasicTypes ( Boxity(..), Arity ) +import StaticFlags ( opt_PprStyle_Debug ) import UniqFM import UniqSet import FastString @@ -93,7 +94,7 @@ type EncodedString = String -- Encoded form pprEncodedFS :: EncodedFS -> SDoc pprEncodedFS fs = getPprStyle $ \ sty -> - if userStyle sty + if userStyle sty || dumpStyle sty -- ftext (decodeFS fs) would needlessly pack the string again then text (decode (unpackFS fs)) else ftext fs @@ -145,11 +146,21 @@ srcDataName = DataName -- Haskell-source data constructors should be tvName = TvName varName = VarName +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 + + nameSpaceString :: NameSpace -> String -nameSpaceString DataName = "Data constructor" -nameSpaceString VarName = "Variable" -nameSpaceString TvName = "Type variable" -nameSpaceString TcClsName = "Type constructor or class" +nameSpaceString DataName = "data constructor" +nameSpaceString VarName = "variable" +nameSpaceString TvName = "type variable" +nameSpaceString TcClsName = "type constructor or class" \end{code} @@ -161,9 +172,9 @@ nameSpaceString TcClsName = "Type constructor or class" \begin{code} data OccName = OccName - NameSpace - EncodedFS - {-! derive : Binary !-} + { occNameSpace :: !NameSpace + , occNameFS :: !EncodedFS + } \end{code} @@ -241,6 +252,9 @@ mkOccName ns s = mkSysOcc ns (encode s) mkVarOcc :: UserFS -> OccName mkVarOcc fs = mkSysOccFS varName (encodeFS fs) +mkTyVarOcc :: UserFS -> OccName +mkTyVarOcc fs = mkSysOccFS tvName (encodeFS fs) + mkVarOccEncoded :: EncodedFS -> OccName mkVarOccEncoded fs = mkSysOccFS varName fs \end{code} @@ -342,18 +356,12 @@ intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) %************************************************************************ \begin{code} -occNameFS :: OccName -> EncodedFS -occNameFS (OccName _ s) = s - 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 @@ -402,9 +410,15 @@ 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 other = False +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} @@ -492,7 +506,7 @@ 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 +-- to VarName mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ \end{code} @@ -515,9 +529,22 @@ mkLocalOcc uniq occ \begin{code} mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> OccName -- "$fOrdMaybe" + -- 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 string = mk_deriv VarName "$f" string +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 @@ -753,6 +780,19 @@ decode_num_esc d rest 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} @@ -793,17 +833,6 @@ count_commas n cs = (n,cs) \end{code} \begin{code} -decode_tuple :: Char -> EncodedString -> UserString -decode_tuple d rest - = go (digitToInt d) rest - where - go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ['T'] = "()" - go n ['T'] = '(' : replicate (n-1) ',' ++ ")" - go 1 ['H'] = "(# #)" - go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)" - go n other = pprPanic "decode_tuple" (ppr n <+> text other) - mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName mkTupleOcc ns bx ar = OccName ns (mkFastString ('Z' : (show ar ++ bx_char)))